![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to spitv35.src CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / spitbol|
Return to spitv35.src CVS log | Up to [Research Unix] / researchv10no / cmd / spitbol |
1.1 root 1: #title s p i t b o l - revision history
2: #page
3: # R E V I S I O N H I S T O R Y
4: # -------------------------------
5: #
6: #
7: # VERSION 3.5B (FEB 81... - SGD PATCHES)
8: # -----------------------------------
9: #
10: # SGD03 - ADDITION OF .CNCI AND SYSCI (INT->STRING
11: # SYSTEM ROUTINE OPTION)
12: # SGD04 - (06-MAY-1981) MODIFIED INILN TO 132
13: # SGD05 - (13-MAY-1981) INSERTED MISSING WTB AFTER SYSMM
14: # CALLS
15: # SGD06 - (25-MAY-1981) MERGED IN PROFILER PATCHES
16: # (NOT MARKED)
17: # SGD07 - (25-MAY-1981) MUCHO PATCHES TO PROFILER (MARKED,
18: # BUT BEST JUST TO EXTRACT ENMASSE)
19: # SGD08 - (25-MAY-1981) USE STRING LENGTH IN HASHS
20: # SGD09 - (25-MAY-1981) FIXED SERIOUS PARSER PROBLEM
21: # RELATING TO (X Y) ON LINE BEING VIEWED AS PATTERN
22: # MATCH. FIXED BY ADDITION OF NEW CMTYP VALUE
23: # C$CNP (CONCATENATION - NOT PATTERN MATCH)
24: # SGD10 - (01-AUG-1981) FIXED EXIT(N) RESPECIFICATION CODE
25: # TO PROPERLY OBSERVE HEADER SEMANTICS ON RETURN.
26: # SGD11 - (07-AUG-1981) BYPASS PRTPG CALL AT INITIALIZATION
27: # FOLLOWING COMPILATION IF NO OUTPUT GENERATED.
28: # THIS PREVENTS OUTPUT FILES CONSISTING OF THE
29: # HEADERS AND A FEW BLANK LINES WHEN THERE IS NO
30: # SOURCE LISTING AND NO COMPILATION STATS.
31: # ALSO FIX TIMSX INITIALIZATION IN SAME CODE.
32: # SGD12 - (17-AUG-1981) B$EFC CODE DID NOT CHECK FOR
33: # UNCONVERTED RESULT RETURNING NULL STRING. FIXED.
34: # SGDBF - ( NOV-1981) ADDED BUFFER TYPE AND SYMBOL CNBF
35: # SGD13 - (03-MAR-1982) LOAD PFVBL FIELD IN RETRN FOR
36: # RETURN TRACING. THIS WAS CAUSING BUG ON RETURN
37: # TRACES THAT TRIED TO ACCESS THE VARIABLE NAME
38: # SGD14 - ADDED CHAR FUNCTION. CHAR(N) RETURNS NTH
39: # CHARACTER OF HOST MACHINE CHARACTER SET.
40: # NOT CONDITIONALIZED OR MARKED.
41: # SGD15 - FIXED PROBLEM RELATING TO COMPILATION OF GOTO
42: # FIELDS CONTAINING SMALL INTEGERS (IN CONST SEC).
43: #
44: # REG01 - (XX-AUG-82)
45: # ADDED CFP$U TO EASE TRANSLATION ON SMALLER
46: # SYSTEMS - CONDITIONAL .CUCF
47: # ADDED LOWER CASE SUPPORT - CONDITIONAL .CULC
48: # ADDED SET I/O FUNCTION - CONDITIONAL .CUST
49: #
50: # REG02 - (XX-SEP-82)
51: # CHANGED INILN AND AND INILS TO 258
52: #
53: # REG03 - (XX-OCT-82)
54: # CONDITIONALIZED THE PAGE EJECT AFTER CALL TO SYSBX
55: # AND ADDED ANOTHER BEFORE CALL TO SYSBX, SO THAT,
56: # IF DESIRED BY THE IMPLEMENTOR, STANDARD OUTPUT
57: # WILL REFLECT ASSIGNMENTS MADE BY EXECUTING PROGRAM
58: # ONLY. CONDITIONAL .CUEJ CONTROLS - IF DEFINED
59: # EJECT IS BEFORE CALL TO SYSBX.
60: #
61: # REG04 - (XX-NOV-82)
62: # FIXED DIFFICULTIES WITH LISTINGS DURING EXECUTION
63: # WHEN NO LISTING GENERATED DURING COMPILATION.
64: #
65: # -LIST TO CODE() CAUSED BOMB. FIX IS TO RESET
66: # R$TTL AND R$STL TO NULLS NOT 0 AFTER COMPILATION.
67: # (LISTR AND LISTT EXPECT NULLS)
68: #
69: # WHEN LISTING AND STATISTICS ROUTED TO DIFFERENT
70: # FILE THAN EXECUTION OUTPUT, ERROR MESSAGE IS SENT
71: # TO EXECUTION OUTPUT (AND GETS SEPARATED FROM
72: # ... IN STATEMENT ... MSG). LABO1 CALLS SYSAX AND
73: # STOPR DOES NOT CALL SYSAX IF ENTERED FROM LABO1.
74: #
75: # REG05 - (XX-NOV-82)
76: # PREVENT CLEAR() FROM CLOBBERING PROTECTED VARIABLES
77: # AT LABEL SCLR5.
78: #
79: # REG06 - (XX-NOV-82)
80: # FIXED GTEXP FROM ACCEPTING TRAILING SEMICOLON OR
81: # COLON. NOT LEGAL WAY TO END AN EXPRESSION.
82: #
83: # VERSION 3.5A (OCT 79 - SGD PATCHES)
84: # -----------------------------------
85: #
86: # SGD01 - PATCH IN ASIGN TO FIX MULTIPLE TRAP BLOCK PROBLEM
87: # (ASG10+2)
88: # SGD02 - PATCH IN GTARR TO FIX NULL CONVERT (GTAR9+0)
89: #
90: #title s p i t b o l -- basic information
91: #page
92: #
93: # GENERAL STRUCTURE
94: # -----------------
95: #
96: # THIS PROGRAM IS A TRANSLATOR FOR A VERSION OF THE SNOBOL4
97: # PROGRAMMING LANGUAGE. LANGUAGE DETAILS ARE CONTAINED IN
98: # THE MANUAL MACRO SPITBOL BY DEWAR AND MCCANN, TECHNICAL
99: # REPORT 90, UNIVERSITY OF LEEDS 1976. THE LANGUAGE
100: # IS IDENTICAL TO THAT IMPLEMENTED BY THE BTL TRANSLATOR
101: # (R. E. GRISWOLD ET AL.) WITH THE FOLLOWING EXCEPTIONS.
102: #
103: # 1) REDEFINITION OF STANDARD SYSTEM FUNCTIONS AND
104: # OPERATORS IS NOT PERMITTED.
105: #
106: # 2) THE VALUE FUNCTION IS NOT PROVIDED.
107: #
108: # 3) ACCESS TRACING IS PROVIDED IN ADDITION TO THE
109: # OTHER STANDARD TRACE MODES.
110: #
111: # 4) THE KEYWORD STFCOUNT IS NOT PROVIDED.
112: #
113: # 5) THE KEYWORD FULLSCAN IS NOT PROVIDED AND ALL PATTERN
114: # MATCHING TAKES PLACE IN FULLSCAN MODE (I.E. WITH NO
115: # HEURISTICS APPLIED).
116: #
117: # 6) A SERIES OF EXPRESSIONS SEPARATED BY COMMAS MAY
118: # BE GROUPED WITHIN PARENTHESES TO PROVIDE A SELECTION
119: # CAPABILITY. THE SEMANTICS ARE THAT THE SELECTION
120: # ASSUMES THE VALUE OF THE FIRST EXPRESSION WITHIN IT
121: # WHICH SUCCEEDS AS THEY ARE EVALUATED FROM THE LEFT.
122: # IF NO EXPRESSION SUCCEEDS THE ENTIRE STATEMENT FAILS
123: #
124: # 7) AN EXPLICIT PATTERN MATCHING OPERATOR IS PROVIDED.
125: # THIS IS THE BINARY QUERY (SEE GIMPEL SIGPLAN OCT 74)
126: #
127: # 8) THE ASSIGNMENT OPERATOR IS INTRODUCED AS IN THE
128: # GIMPEL REFERENCE.
129: #
130: # 9) THE EXIT FUNCTION IS PROVIDED FOR GENERATING LOAD
131: # MODULES - CF. GIMPELS SITBOL.
132: #
133: #
134: # THE METHOD USED IN THIS PROGRAM IS TO TRANSLATE THE
135: # SOURCE CODE INTO AN INTERNAL PSEUDO-CODE (SEE FOLLOWING
136: # SECTION). AN INTERPRETOR IS THEN USED TO EXECUTE THIS
137: # GENERATED PSEUDO-CODE. THE NATURE OF THE SNOBOL4 LANGUAGE
138: # IS SUCH THAT THE LATTER TASK IS MUCH MORE COMPLEX THAN
139: # THE ACTUAL TRANSLATION PHASE. ACCORDINGLY, NEARLY ALL THE
140: # CODE IN THE PROGRAM SECTION IS CONCERNED WITH THE ACTUAL
141: # EXECUTION OF THE SNOBOL4 PROGRAM.
142: #page
143: #
144: # INTERPRETIVE CODE FORMAT
145: # ------------------------
146: #
147: # THE INTERPRETIVE PSEUDO-CODE CONSISTS OF A SERIES OF
148: # ADDRESS POINTERS. THE EXACT FORMAT OF THE CODE IS
149: # DESCRIBED IN CONNECTION WITH THE CDBLK FORMAT. THE
150: # PURPOSE OF THIS SECTION IS TO GIVE GENERAL INSIGHT INTO
151: # THE INTERPRETIVE APPROACH INVOLVED.
152: #
153: # THE BASIC FORM OF THE CODE IS RELATED TO REVERSE POLISH.
154: # IN OTHER WORDS, THE OPERANDS PRECEDE THE OPERATORS WHICH
155: # ARE ZERO ADDRESS OPERATORS. THERE ARE SOME EXCEPTIONS TO
156: # THESE RULES, NOTABLY THE UNARY NOT OPERATOR AND THE
157: # SELECTION CONSTRUCTION WHICH CLEARLY REQUIRE ADVANCE
158: # KNOWLEDGE OF THE OPERATOR INVOLVED.
159: #
160: # THE OPERANDS ARE MOVED TO THE TOP OF THE MAIN STACK AND
161: # THE OPERATORS ARE APPLIED TO THE TOP STACK ENTRIES. LIKE
162: # OTHER VERSIONS OF SPITBOL, THIS PROCESSOR DEPENDS ON
163: # KNOWING WHETHER OPERANDS ARE REQUIRED BY NAME OR BY VALUE
164: # AND MOVES THE APPROPRIATE OBJECT TO THE STACK. THUS NO
165: # NAME/VALUE CHECKS ARE INCLUDED IN THE OPERATOR CIRCUITS.
166: #
167: # THE ACTUAL POINTERS IN THE CODE POINT TO A BLOCK WHOSE
168: # FIRST WORD IS THE ADDRESS OF THE INTERPRETOR ROUTINE
169: # TO BE EXECUTED FOR THE CODE WORD.
170: #
171: # IN THE CASE OF OPERATORS, THE POINTER IS TO A WORD WHICH
172: # CONTAINS THE ADDRESS OF THE OPERATOR TO BE EXECUTED. IN
173: # THE CASE OF OPERANDS SUCH AS CONSTANTS, THE POINTER IS TO
174: # THE OPERAND ITSELF. ACCORDINGLY, ALL OPERANDS CONTAIN
175: # A FIELD WHICH POINTS TO THE ROUTINE TO LOAD THE VALUE OF
176: # THE OPERAND ONTO THE STACK. IN THE CASE OF A VARIABLE,
177: # THERE ARE THREE SUCH POINTERS. ONE TO LOAD THE VALUE,
178: # ONE TO STORE THE VALUE AND A THIRD TO JUMP TO THE LABEL.
179: #
180: # THE HANDLING OF FAILURE RETURNS DESERVES SPECIAL COMMENT.
181: # THE LOCATION FLPTR CONTAINS THE POINTER TO THE LOCATION
182: # ON THE MAIN STACK WHICH CONTAINS THE FAILURE RETURN
183: # WHICH IS IN THE FORM OF A BYTE OFFSET IN THE CURRENT
184: # CODE BLOCK (CDBLK OR EXBLK). WHEN A FAILURE OCCURS, THE
185: # STACK IS POPPED AS INDICATED BY THE SETTING OF FLPTR AND
186: # CONTROL IS PASSED TO THE APPROPRIATE LOCATION IN THE
187: # CURRENT CODE BLOCK WITH THE STACK POINTER POINTING TO THE
188: # FAILURE OFFSET ON THE STACK AND FLPTR UNCHANGED.
189: #page
190: #
191: # INTERNAL DATA REPRESENTATIONS
192: # -----------------------------
193: #
194: # REPRESENTATION OF VALUES
195: #
196: # A VALUE IS REPRESENTED BY A POINTER TO A BLOCK WHICH
197: # DESCRIBES THE TYPE AND PARTICULARS OF THE DATA VALUE.
198: # IN GENERAL, A VARIABLE IS A LOCATION CONTAINING SUCH A
199: # POINTER (ALTHOUGH IN THE CASE OF TRACE ASSOCIATIONS THIS
200: # IS MODIFIED, SEE DESCRIPTION OF TRBLK).
201: #
202: # THE FOLLOWING IS A LIST OF POSSIBLE DATATYPES SHOWING THE
203: # TYPE OF BLOCK USED TO HOLD THE VALUE. THE DETAILS OF
204: # EACH BLOCK FORMAT ARE GIVEN LATER.
205: #
206: # DATATYPE BLOCK TYPE
207: # -------- ----------
208: #
209: #
210: # ARRAY ARBLK OR VCBLK
211: #
212: # CODE CDBLK
213: #
214: # EXPRESSION EXBLK OR SEBLK
215: #
216: # INTEGER ICBLK
217: #
218: # NAME NMBLK
219: #
220: # PATTERN P0BLK OR P1BLK OR P2BLK
221: #
222: # REAL RCBLK
223: #
224: # STRING SCBLK
225: #
226: # TABLE TBBLK
227: #
228: # PROGRAM DATATYPE PDBLK
229: #page
230: #
231: # REPRESENTATION OF VARIABLES
232: # ---------------------------
233: #
234: # DURING THE COURSE OF EVALUATING EXPRESSIONS, IT IS
235: # NECESSARY TO GENERATE NAMES OF VARIABLES (FOR EXAMPLE
236: # ON THE LEFT SIDE OF A BINARY EQUALS OPERATOR). THESE ARE
237: # NOT TO BE CONFUSED WITH OBJECTS OF DATATYPE NAME WHICH
238: # ARE IN FACT VALUES.
239: #
240: # FROM A LOGICAL POINT OF VIEW, SUCH NAMES COULD BE SIMPLY
241: # REPRESENTED BY A POINTER TO THE APPROPRIATE VALUE CELL.
242: # HOWEVER IN THE CASE OF ARRAYS AND PROGRAM DEFINED
243: # DATATYPES, THIS WOULD VIOLATE THE RULE THAT THERE MUST BE
244: # NO POINTERS INTO THE MIDDLE OF A BLOCK IN DYNAMIC STORE.
245: # ACCORDINGLY, A NAME IS ALWAYS REPRESENTED BY A BASE AND
246: # OFFSET. THE BASE POINTS TO THE START OF THE BLOCK
247: # CONTAINING THE VARIABLE VALUE AND THE OFFSET IS THE
248: # OFFSET WITHIN THIS BLOCK IN BYTES. THUS THE ADDRESS
249: # OF THE ACTUAL VARIABLE IS DETERMINED BY ADDING THE BASE
250: # AND OFFSET VALUES.
251: #
252: # THE FOLLOWING ARE THE INSTANCES OF VARIABLES REPRESENTED
253: # IN THIS MANNER.
254: #
255: # 1) NATURAL VARIABLE BASE IS PTR TO VRBLK
256: # OFFSET IS *VRVAL
257: #
258: # 2) TABLE ELEMENT BASE IS PTR TO TEBLK
259: # OFFSET IS *TEVAL
260: #
261: # 3) ARRAY ELEMENT BASE IS PTR TO ARBLK
262: # OFFSET IS OFFSET TO ELEMENT
263: #
264: # 4) VECTOR ELEMENT BASE IS PTR TO VCBLK
265: # OFFSET IS OFFSET TO ELEMENT
266: #
267: # 5) PROG DEF DTP BASE IS PTR TO PDBLK
268: # OFFSET IS OFFSET TO FIELD VALUE
269: #
270: # IN ADDITION THERE ARE TWO CASES OF OBJECTS WHICH ARE
271: # LIKE VARIABLES BUT CANNOT BE HANDLED IN THIS MANNER.
272: # THESE ARE CALLED PSEUDO-VARIABLES AND ARE REPRESENTED
273: # WITH A SPECIAL BASE POINTER AS FOLLOWS=
274: #
275: # EXPRESSION VARIABLE PTR TO EVBLK (SEE EVBLK)
276: #
277: # KEYWORD VARIABLE PTR TO KVBLK (SEE KVBLK)
278: #
279: # PSEUDO-VARIABLES ARE HANDLED AS SPECIAL CASES BY THE
280: # ACCESS PROCEDURE (ACESS) AND THE ASSIGNMENT PROCEDURE
281: # (ASIGN). SEE THESE TWO PROCEDURES FOR DETAILS.
282: #page
283: #
284: # ORGANIZATION OF DATA AREA
285: # -------------------------
286: #
287: #
288: # THE DATA AREA IS DIVIDED INTO TWO REGIONS.
289: #
290: # STATIC AREA
291: #
292: # THE STATIC AREA BUILDS UP FROM THE BOTTOM AND CONTAINS
293: # DATA AREAS WHICH ARE ALLOCATED DYNAMICALLY BUT ARE NEVER
294: # DELETED OR MOVED AROUND. THE MACRO-PROGRAM ITSELF
295: # USES THE STATIC AREA FOR THE FOLLOWING.
296: #
297: # 1) ALL VARIABLE BLOCKS (VRBLK).
298: #
299: # 2) THE HASH TABLE FOR VARIABLE BLOCKS.
300: #
301: # 3) MISCELLANEOUS BUFFERS AND WORK AREAS (SEE PROGRAM
302: # INITIALIZATION SECTION).
303: #
304: # IN ADDITION, THE SYSTEM PROCEDURES MAY USE THIS AREA FOR
305: # INPUT/OUTPUT BUFFERS, EXTERNAL FUNCTIONS ETC. SPACE IN
306: # THE STATIC REGION IS ALLOCATED BY CALLING PROCEDURE ALOST
307: #
308: # THE FOLLOWING GLOBAL VARIABLES DEFINE THE CURRENT
309: # LOCATION AND SIZE OF THE STATIC AREA.
310: #
311: # STATB ADDRESS OF START OF STATIC AREA
312: # STATE ADDRESS+1 OF LAST WORD IN AREA.
313: #
314: # THE MINIMUM SIZE OF STATIC IS GIVEN APPROXIMATELY BY
315: # 12 + *E$HNB + *E$STS + SPACE FOR ALPHABET STRING
316: # AND STANDARD PRINT BUFFER.
317: #page
318: #
319: # DYNAMIC AREA
320: #
321: # THE DYNAMIC AREA IS BUILT UPWARDS IN MEMORY AFTER THE
322: # STATIC REGION. DATA IN THIS AREA MUST ALL BE IN STANDARD
323: # BLOCK FORMATS SO THAT IT CAN BE PROCESSED BY THE GARBAGE
324: # COLLECTOR (PROCEDURE GBCOL). GBCOL COMPACTS BLOCKS DOWN
325: # IN THIS REGION AS REQUIRED BY SPACE EXHAUSTION AND CAN
326: # ALSO MOVE ALL BLOCKS UP TO ALLOW FOR EXPANSION OF THE
327: # STATIC REGION.
328: # WITH THE EXCEPTION OF TABLES AND ARRAYS, NO SPITBOL
329: # OBJECT ONCE BUILT IN DYNAMIC MEMORY IS EVER SUBSEQUENTLY
330: # MODIFIED. OBSERVING THIS RULE NECESSITATES A COPYING
331: # ACTION DURING STRING AND PATTERN CONCATENATION.
332: #
333: # GARBAGE COLLECTION IS FUNDAMENTAL TO THE ALLOCATION OF
334: # SPACE FOR VALUES. SPITBOL USES A VERY EFFICIENT GARBAGE
335: # COLLECTOR WHICH INSISTS THAT POINTERS INTO DYNAMIC STORE
336: # SHOULD BE IDENTIFIABLE WITHOUT USE OF BIT TABLES,
337: # MARKER BITS ETC. TO SATISFY THIS REQUIREMENT, DYNAMIC
338: # MEMORY MUST NOT START AT TOO LOW AN ADDRESS AND LENGTHS
339: # OF ARRAYS, TABLES, STRINGS, CODE AND EXPRESSION BLOCKS
340: # MAY NOT EXCEED THE NUMERICAL VALUE OF THE LOWEST DYNAMIC
341: # ADDRESS. TO AVOID EITHER PENALIZING USERS WITH MODEST
342: # REQUIREMENTS OR RESTRICTING THOSE WITH GREATER NEEDS ON
343: # HOST SYSTEMS WHERE DYNAMIC MEMORY IS ALLOCATED IN LOW
344: # ADDRESSES, THE MINIMUM DYNAMIC ADDRESS MAY BE SPECIFIED
345: # SUFFICIENTLY HIGH TO PERMIT ARBITRARILY LARGE SPITBOL
346: # OBJECTS TO BE CREATED ( WITH THE POSSIBILITY IN EXTREME
347: # CASES OF WASTING LARGE AMOUNTS OF MEMORY BELOW THE
348: # START ADDRESS). THIS MINIMUM VALUE IS MADE AVAILABLE
349: # IN VARIABLE MXLEN BY A SYSTEM ROUTINE, SYSMX.
350: # ALTERNATIVELY SYSMX MAY INDICATE THAT A
351: # DEFAULT MAY BE USED IN WHICH DYNAMIC IS PLACED
352: # AT THE LOWEST POSSIBLE ADDRESS FOLLOWING STATIC.
353: #
354: # THE FOLLOWING GLOBAL WORK CELLS DEFINE THE LOCATION AND
355: # LENGTH OF THE DYNAMIC AREA.
356: #
357: # DNAMB START OF DYNAMIC AREA
358: # DNAMP NEXT AVAILABLE LOCATION
359: # DNAME LAST AVAILABLE LOCATION + 1
360: #
361: # DNAMB IS ALWAYS HIGHER THAN STATE SINCE THE ALOST
362: # PROCEDURE MAINTAINS SOME EXPANSION SPACE ABOVE STATE.
363: # *** DNAMB MUST NEVER BE PERMITTED TO HAVE A VALUE LESS
364: # THAN THAT IN MXLEN ***
365: #
366: # SPACE IN THE DYNAMIC REGION IS ALLOCATED BY THE ALLOC
367: # PROCEDURE. THE DYNAMIC REGION MAY BE USED BY SYSTEM
368: # PROCEDURES PROVIDED THAT ALL THE RULES ARE OBEYED.
369: #page
370: #
371: # REGISTER USAGE
372: # --------------
373: #
374: # (CP) CODE POINTER REGISTER. USED TO
375: # HOLD A POINTER TO THE CURRENT
376: # LOCATION IN THE INTERPRETIVE PSEUDO
377: # CODE (I.E. PTR INTO A CDBLK).
378: #
379: # (XL,XR) GENERAL INDEX REGISTERS. USUALLY
380: # USED TO HOLD POINTERS TO BLOCKS IN
381: # DYNAMIC STORAGE. AN IMPORTANT
382: # RESTRICTION IS THAT THE VALUE IN
383: # XL MUST BE COLLECTABLE FOR
384: # A GARBAGE COLLECT CALL. A VALUE
385: # IS COLLECTABLE IF IT EITHER POINTS
386: # OUTSIDE THE DYNAMIC AREA, OR IF IT
387: # POINTS TO THE START OF A BLOCK IN
388: # THE DYNAMIC AREA.
389: #
390: # (XS) STACK POINTER. USED TO POINT TO
391: # THE STACK FRONT. THE STACK MAY
392: # BUILD UP OR DOWN AND IS USED
393: # TO STACK SUBROUTINE RETURN POINTS
394: # AND OTHER RECURSIVELY SAVED DATA.
395: #
396: # (XT) AN ALTERNATIVE NAME FOR XL DURING
397: # ITS USE IN ACCESSING STACKED ITEMS.
398: #
399: # (WA,WB,WC) GENERAL WORK REGISTERS. CANNOT BE
400: # USED FOR INDEXING, BUT MAY HOLD
401: # VARIOUS TYPES OF DATA.
402: #
403: # (IA) USED FOR ALL SIGNED INTEGER
404: # ARITHMETIC, BOTH THAT USED BY THE
405: # TRANSLATOR AND THAT ARISING FROM
406: # USE OF SNOBOL4 ARITHMETIC OPERATORS
407: #
408: # (RA) REAL ACCUMULATOR. USED FOR ALL
409: # FLOATING POINT ARITHMETIC.
410: #page
411: #
412: # SPITBOL CONDITIONAL ASSEMBLY SYMBOLS
413: # ------------------------------------
414: #
415: # IN THE SPITBOL TRANSLATOR, THE FOLLOWING CONDITIONAL
416: # ASSEMBLY SYMBOLS ARE REFERRED TO. TO INCORPORATE THE
417: # FEATURES REFERRED TO, THE MINIMAL SOURCE SHOULD BE
418: # PREFACED BY SUITABLE CONDITIONAL ASSEMBLY SYMBOL
419: # DEFINITIONS.
420: # IN ALL CASES IT IS PERMISSIBLE TO DEFAULT THE DEFINITIONS
421: # IN WHICH CASE THE ADDITIONAL FEATURES WILL BE OMITTED
422: # FROM THE TARGET CODE.
423: #
424: # .CASL DEFINE TO INCLUDE 26 SHIFTED LETTRS
425: # .CAHT DEFINE TO INCLUDE HORIZONTAL TAB
426: # .CAVT DEFINE TO INCLUDE VERTICAL TAB
427: # .CIOD IF DEFINED, DEFAULT DELIMITER IS
428: # NOT USED IN PROCESSING 3RD ARG OF
429: # INPUT() AND OUTPUT()
430: # .CNBT DEFINE TO OMIT BATCH INITIALISATION
431: # .CNCI DEFINE TO ENABLE SYSCI ROUTINE
432: # .CNEX DEFINE TO OMIT EXIT() CODE.
433: # .CNLD DEFINE TO OMIT LOAD() CODE.
434: # .CNPF DEFINE TO OMIT PROFILE STUFF
435: # .CNRA DEFINE TO OMIT ALL REAL ARITHMETIC
436: # .CNSR DEFINE TO OMIT SORT, RSORT
437: # .CSAX DEFINE IF SYSAX IS TO BE CALLED
438: # .CSN6 DEFINE TO PAD STMT NOS TO 6 CHARS
439: # .CSN8 DEFINE TO PAD STMT NOS TO 8 CHARS
440: # .CUCF DEFINE TO INCLUDE CFP$U
441: # .CULC DEFINE TO INCLUDE &CASE (LC NAMES)
442: # .CUST DEFINE TO INCLUDE SET() CODE
443: #title s p i t b o l -- procedures section
444: #
445: # THIS SECTION STARTS WITH DESCRIPTIONS OF THE OPERATING
446: # SYSTEM DEPENDENT PROCEDURES WHICH ARE USED BY THE SPITBOL
447: # TRANSLATOR. ALL SUCH PROCEDURES HAVE FIVE LETTER NAMES
448: # BEGINNING WITH SYS. THEY ARE LISTED IN ALPHABETICAL
449: # ORDER.
450: # ALL PROCEDURES HAVE A SPECIFICATION CONSISTING OF A
451: # MODEL CALL, PRECEDED BY A POSSIBLY EMPTY LIST OF REGISTER
452: # CONTENTS GIVING PARAMETERS AVAILABLE TO THE PROCEDURE AND
453: # FOLLOWED BY A POSSIBLY EMPTY LIST OF REGISTER CONTENTS
454: # REQUIRED ON RETURN FROM THE CALL OR WHICH MAY HAVE HAD
455: # THEIR CONTENTS DESTROYED. ONLY THOSE REGISTERS EXPLICITLY
456: # MENTIONED IN THE LIST AFTER THE CALL MAY HAVE THEIR
457: # VALUES CHANGED.
458: # THE SEGMENT OF CODE PROVIDING THE EXTERNAL PROCEDURES IS
459: # CONVENIENTLY REFERRED TO AS OSINT (OPERATING SYSTEM
460: # INTERFACE). THE SYSXX PROCEDURES IT CONTAINS PROVIDE
461: # FACILITIES NOT USUALLY AVAILABLE AS PRIMITIVES IN
462: # ASSEMBLY LANGUAGES. FOR PARTICULAR TARGET MACHINES,
463: # IMPLEMENTORS MAY CHOOSE FOR SOME MINIMAL OPCODES WHICH
464: # DO NOT HAVE REASONABLY DIRECT TRANSLATIONS, TO USE CALLS
465: # OF ADDITIONAL PROCEDURES WHICH THEY PROVIDE IN OSINT.
466: # E.G. MWB OR TRC MIGHT BE TRANSLATED AS JSR SYSMB,
467: # JSR SYSTC IN SOME IMPLEMENTATIONS.
468: #
469: # IN THE DESCRIPTIONS, REFERENCE IS MADE TO --BLK
470: # FORMATS (-- = A PAIR OF LETTERS). SEE THE SPITBOL
471: # DEFINITIONS SECTION FOR DETAILED DESCRIPTIONS OF ALL
472: # SUCH BLOCK FORMATS EXCEPT FCBLK FOR WHICH SYSFC SHOULD
473: # BE CONSULTED.
474: #
475: # SECTION 0 CONTAINS INP,INR SPECIFICATIONS OF INTERNAL
476: # PROCEDURES,ROUTINES. THIS GIVES A SINGLE PASS TRANSLATOR
477: # INFORMATION MAKING IT EASY TO GENERATE ALTERNATIVE CALLS
478: # IN THE TRANSLATION OF JSR-S FOR PROCEDURES OF DIFFERENT
479: # TYPES IF THIS PROVES NECESSARY.
480: #
481: #sec # start of procedures section
482: #page
483: #
484: # SYSAX -- AFTER EXECUTION
485: #
486: .globl sysax # define external entry point
487: #
488: # IF THE CONDITIONAL ASSEMBLY SYMBOL .CSAX IS DEFINED,
489: # THIS ROUTINE IS CALLED IMMEDIATELY AFTER EXECUTION AND
490: # BEFORE PRINTING OF EXECUTION STATISTICS OR DUMP OUTPUT.
491: # PURPOSE OF CALL IS FOR IMPLEMENTOR TO DETERMINE AND
492: # IF THE CALL IS NOT REQUIRED IT WILL BE OMITTED IF .CSAX
493: # IS UNDEFINED. IN THIS CASE SYSAX NEED NOT BE CODED.
494: #
495: # JSR SYSAX CALL AFTER EXECUTION
496: #page
497: #
498: # SYSBX -- BEFORE EXECUTION
499: #
500: .globl sysbx # define external entry point
501: #
502: # CALLED AFTER INITIAL SPITBOL COMPILATION AND BEFORE
503: # COMMENCING EXECUTION IN CASE OSINT NEEDS
504: # TO ASSIGN FILES OR PERFORM OTHER NECESSARY SERVICES.
505: # OSINT MAY ALSO CHOOSE TO SEND A MESSAGE TO ONLINE
506: # TERMINAL (IF ANY) INDICATING THAT EXECUTION IS STARTING.
507: #
508: # JSR SYSBX CALL BEFORE EXECUTION STARTS
509: #page
510: #
511: # SYSDC -- DATE CHECK
512: #
513: .globl sysdc # define external entry point
514: #
515: # SYSDC IS CALLED TO CHECK THAT THE EXPIRY DATE FOR A TRIAL
516: # VERSION OF SPITBOL IS UNEXPIRED.
517: #
518: # JSR SYSDC CALL TO CHECK DATE
519: # RETURN ONLY IF DATE IS OK
520: #page
521: #
522: # SYSDM -- DUMP CORE
523: #
524: .globl sysdm # define external entry point
525: #
526: # SYSDM IS CALLED BY A SPITBOL PROGRAM CALL OF DUMP(N) WITH
527: # N GE 3. ITS PURPOSE IS TO PROVIDE A CORE DUMP.
528: # N COULD HOLD AN ENCODING OF THE START ADRS FOR DUMP AND
529: # AMOUNT TO BE DUMPED E.G. N = 256*A + S , S = START ADRS
530: # IN KILOWORDS, A = KILOWORDS TO DUMP
531: #
532: # (XR) PARAMETER N OF CALL DUMP(N)
533: # JSR SYSDM CALL TO ENTER ROUTINE
534: #page
535: #
536: # SYSDT -- GET CURRENT DATE
537: #
538: .globl sysdt # define external entry point
539: #
540: # SYSDT IS USED TO OBTAIN THE CURRENT DATE. THE DATE IS
541: # RETURNED AS A CHARACTER STRING IN ANY FORMAT APPROPRIATE
542: # TO THE OPERATING SYSTEM IN USE. IT MAY ALSO CONTAIN THE
543: # CURRENT TIME OF DAY. SYSDT IS USED TO IMPLEMENT THE
544: # SNOBOL4 FUNCTION DATE.
545: #
546: # JSR SYSDT CALL TO GET DATE
547: # (XL) POINTER TO BLOCK CONTAINING DATE
548: #
549: # THE FORMAT OF THE BLOCK IS LIKE AN SCBLK EXCEPT THAT
550: # THE FIRST WORD NEED NOT BE SET. THE RESULT IS COPIED
551: # INTO SPITBOL DYNAMIC MEMORY ON RETURN.
552: #page
553: #
554: # SYSEF -- EJECT FILE
555: #
556: .globl sysef # define external entry point
557: #
558: # SYSEF IS USED TO WRITE A PAGE EJECT TO A NAMED FILE. IT
559: # MAY ONLY BE USED FOR FILES WHERE THIS CONCEPT MAKES
560: # SENSE. NOTE THAT SYSEF IS NOT NORMALLY USED FOR THE
561: # STANDARD OUTPUT FILE (SEE SYSEP).
562: #
563: # (WA) PTR TO FCBLK OR ZERO
564: # (XR) EJECT ARGUMENT (SCBLK PTR)
565: # JSR SYSEF CALL TO EJECT FILE
566: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST
567: # PPM LOC RETURN HERE IF INAPPROPRIATE FILE
568: # PPM LOC RETURN HERE IF I/O ERROR
569: #page
570: #
571: # SYSEJ -- END OF JOB
572: #
573: .globl sysej # define external entry point
574: #
575: # SYSEJ IS CALLED ONCE AT THE END OF EXECUTION TO
576: # TERMINATE THE RUN. THE SIGNIFICANCE OF THE ABEND AND
577: # CODE VALUES IS SYSTEM DEPENDENT. IN GENERAL, THE CODE
578: # VALUE SHOULD BE MADE AVAILABLE FOR TESTING, AND THE
579: # ABEND VALUE SHOULD CAUSE SOME POST-MORTEM ACTION SUCH AS
580: # A DUMP. NOTE THAT SYSEJ DOES NOT RETURN TO ITS CALLER.
581: # SEE SYSXI FOR DETAILS OF FCBLK CHAIN
582: #
583: # (WA) VALUE OF ABEND KEYWORD
584: # (WB) VALUE OF CODE KEYWORD
585: # (XL) O OR PTR TO HEAD OF FCBLK CHAIN
586: # JSR SYSEJ CALL TO END JOB
587: #
588: # THE FOLLOWING SPECIAL VALUES ARE USED AS CODES IN (WB)
589: # 999 EXECUTION SUPPRESSED
590: # 998 STANDARD OUTPUT FILE FULL OR UNAVAILABLE IN A SYSXI
591: # LOAD MODULE. IN THESE CASES (WA) CONTAINS THE NUMBER
592: # OF THE STATEMENT CAUSING PREMATURE TERMINATION.
593: #page
594: #
595: # SYSEM -- GET ERROR MESSAGE TEXT
596: #
597: .globl sysem # define external entry point
598: #
599: # SYSEM IS USED TO OBTAIN THE TEXT OF ERR, ERB CALLS IN THE
600: # SOURCE PROGRAM GIVEN THE ERROR CODE NUMBER. IT IS ALLOWED
601: # TO RETURN A NULL STRING IF THIS FACILITY IS UNAVAILABLE.
602: #
603: # (WA) ERROR CODE NUMBER
604: # JSR SYSEM CALL TO GET TEXT
605: # (XR) TEXT OF MESSAGE
606: #
607: # THE RETURNED VALUE IS A POINTER TO A BLOCK IN SCBLK
608: # FORMAT EXCEPT THAT THE FIRST WORD NEED NOT BE SET. THE
609: # STRING IS COPIED INTO DYNAMIC MEMORY ON RETURN.
610: # IF THE NULL STRING IS RETURNED EITHER BECAUSE SYSEM DOES
611: # NOT PROVIDE ERROR MESSAGE TEXTS OR BECAUSE WA IS OUT OF
612: # RANGE, SPITBOL WILL PRINT THE STRING STORED IN ERRTEXT
613: # KEYWORD.
614: #page
615: #
616: # SYSEN -- ENDFILE
617: #
618: .globl sysen # define external entry point
619: #
620: # SYSEN IS USED TO IMPLEMENT THE SNOBOL4 FUNCTION ENDFILE.
621: # THE MEANING IS SYSTEM DEPENDENT. IN GENERAL, ENDFILE
622: # IMPLIES THAT NO FURTHER I/O OPERATIONS WILL BE PERFORMED,
623: # BUT DOES NOT GUARANTEE THIS TO BE THE CASE. THE FILE
624: # SHOULD BE CLOSED AFTER THE CALL, A SUBSEQUENT READ
625: # OR WRITE MAY REOPEN THE FILE AT THE START OR IT MAY BE
626: # NECESSARY TO REOPEN THE FILE VIA SYSIO.
627: #
628: # (WA) PTR TO FCBLK OR ZERO
629: # (XR) ENDFILE ARGUMENT (SCBLK PTR)
630: # JSR SYSEN CALL TO ENDFILE
631: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST
632: # PPM LOC RETURN HERE IF ENDFILE NOT ALLOWED
633: # PPM LOC RETURN HERE IF I/O ERROR
634: # (WA,WB) DESTROYED
635: #
636: # THE SECOND ERROR RETURN IS USED FOR FILES FOR WHICH
637: # ENDFILE IS NOT PERMITTED. FOR EXAMPLE, IT MAY BE EXPECTED
638: # THAT THE STANDARD INPUT AND OUTPUT FILES ARE IN THIS
639: # CATEGORY.
640: #page
641: #
642: # SYSEP -- EJECT PRINTER PAGE
643: #
644: .globl sysep # define external entry point
645: #
646: # SYSEP IS CALLED TO PERFORM A PAGE EJECT ON THE STANDARD
647: # PRINTER OUTPUT FILE (CORRESPONDING TO SYSPR OUTPUT).
648: #
649: # JSR SYSEP CALL TO EJECT PRINTER OUTPUT
650: #page
651: #
652: # SYSEX -- CALL EXTERNAL FUNCTION
653: #
654: .globl sysex # define external entry point
655: #
656: # SYSEX IS CALLED TO PASS CONTROL TO AN EXTERNAL FUNCTION
657: # PREVIOUSLY LOADED WITH A CALL TO SYSLD.
658: #
659: # (XS) POINTER TO ARGUMENTS ON STACK
660: # (XL) POINTER TO CONTROL BLOCK (EFBLK)
661: # (WA) NUMBER OF ARGUMENTS ON STACK
662: # JSR SYSEX CALL TO PASS CONTROL TO FUNCTION
663: # PPM LOC RETURN HERE IF FUNCTION CALL FAILS
664: # (XS) POPPED PAST ARGUMENTS
665: # (XR) RESULT RETURNED
666: #
667: # THE ARGUMENTS ARE STORED ON THE STACK WITH
668: # THE LAST ARGUMENT AT 0(XS). ON RETURN, XS
669: # IS POPPED PAST THE ARGUMENTS.
670: #
671: # THE FORM OF THE ARGUMENTS AS PASSED IS THAT USED IN THE
672: # SPITBOL TRANSLATOR (SEE DEFINITIONS AND DATA STRUCTURES
673: # SECTION). THE CONTROL BLOCK FORMAT IS ALSO DESCRIBED
674: # (UNDER EFBLK) IN THIS SECTION.
675: #
676: # THERE ARE TWO WAYS OF RETURNING A RESULT.
677: #
678: # 1) RETURN A POINTER TO A BLOCK IN DYNAMIC STORAGE. THIS
679: # BLOCK MUST BE IN EXACTLY CORRECT FORMAT, INCLUDING
680: # THE FIRST WORD. ONLY FUNCTIONS WRITTEN WITH INTIMATE
681: # KNOWLEDGE OF THE SYSTEM WILL RETURN IN THIS WAY.
682: #
683: # 2) STRING, INTEGER AND REAL RESULTS MAY BE RETURNED BY
684: # POINTING TO A PSEUDO-BLOCK OUTSIDE DYNAMIC MEMORY.
685: # THIS BLOCK IS IN ICBLK, RCBLK OR SCBLK FORMAT EXCEPT
686: # THAT THE FIRST WORD WILL BE OVERWRITTEN
687: # BY A TYPE WORD ON RETURN AND SO NEED NOT
688: # BE CORRECTLY SET. SUCH A RESULT IS
689: # COPIED INTO MAIN STORAGE BEFORE PROCEEDING.
690: # UNCONVERTED RESULTS MAY SIMILARLY BE RETURNED IN A
691: # PSEUDO-BLOCK WHICH IS IN CORRECT FORMAT INCLUDING
692: # TYPE WORD RECOGNISABLE BY GARBAGE COLLECTOR SINCE
693: # BLOCK IS COPIED INTO DYNAMIC MEMORY.
694: #page
695: #
696: # SYSFC -- FILE CONTROL BLOCK ROUTINE
697: #
698: .globl sysfc # define external entry point
699: #
700: # SEE ALSO SYSIO
701: # INPUT AND OUTPUT HAVE 3 ARGUMENTS REFERRED TO AS SHOWN
702: # INPUT(VARIABLE NAME,FILE ARG1,FILE ARG2)
703: # OUTPUT(VARIABLE NAME,FILE ARG1,FILE ARG2)
704: # FILE ARG1 MAY BE AN INTEGER OR STRING USED TO IDENTIFY
705: # AN I/O CHANNEL. IT IS CONVERTED TO A STRING FOR CHECKING.
706: # THE EXACT SIGNIFICANCE OF FILE ARG2
707: # IS NOT RIGOROUSLY PRESCRIBED BUT TO IMPROVE PORTABILITY,
708: # THE SCHEME DESCRIBED IN THE SPITBOL USER MANUAL
709: # SHOULD BE ADOPTED WHEN POSSIBLE. THE PREFERRED FORM IS
710: # A STRING $F$,R$R$,C$C$,I$I$,...,Z$Z$ WHERE
711: # $F$ IS AN OPTIONAL FILE NAME WHICH IS PLACED FIRST.
712: # REMAINING ITEMS MAY BE OMITTED OR INCLUDED IN ANY ORDER.
713: # $R$ IS MAXIMUM RECORD LENGTH
714: # $C$ IS A CARRIAGE CONTROL CHARACTER OR CHARACTER STRING
715: # $I$ IS SOME FORM OF CHANNEL IDENTIFICATION USED IN THE
716: # ABSENCE OF $F$ TO ASSOCIATE THE VARIABLE
717: # WITH A FILE ALLOCATED DYNAMICALLY BY JCL COMMANDS AT
718: # SPITBOL LOAD TIME.
719: # ,...,Z$Z$ ARE ADDITIONAL FIELDS.
720: # IF , (COMMA) CANNOT BE USED AS A DELIMITER, .CIOD
721: # SHOULD BE DEFINED TO INTRODUCE BY CONDITIONAL ASSEMBLY
722: # ANOTHER DELIMITER (SEE
723: # IODEL EQU *
724: # EARLY IN DEFINITIONS SECTION).
725: # SYSFC IS CALLED WHEN A VARIABLE IS INPUT OR OUTPUT
726: # ASSOCIATED TO CHECK FILE ARG1 AND FILE ARG2 AND
727: # TO REPORT WHETHER AN FCBLK (FILE CONTROL
728: # BLOCK) IS NECESSARY AND IF SO WHAT SIZE IT SHOULD BE.
729: # THIS MAKES IT POSSIBLE FOR SPITBOL RATHER THAN OSINT TO
730: # ALLOCATE SUCH A BLOCK IN DYNAMIC MEMORY IF REQUIRED
731: # OR ALTERNATIVELY IN STATIC MEMORY.
732: # THE SIGNIFICANCE OF AN FCBLK , IF ONE IS REQUESTED, IS
733: # ENTIRELY UP TO THE SYSTEM INTERFACE. THE ONLY RESTRICTION
734: # IS THAT IF THE FCBLK SHOULD APPEAR TO LIE IN DYNAMIC
735: # MEMORY , POINTERS TO IT SHOULD BE PROPER POINTERS TO
736: # THE START OF A RECOGNISABLE AND GARBAGE COLLECTABLE
737: # BLOCK (THIS CONDITION WILL BE MET IF SYSFC REQUESTS
738: # SPITBOL TO PROVIDE AN FCBLK).
739: # AN OPTION IS PROVIDED FOR OSINT TO RETURN A POINTER IN
740: # XL TO AN FCBLK WHICH IT PRIVATELY ALLOCATED. THIS PTR
741: # WILL BE MADE AVAILABLE WHEN I/O OCCURS LATER.
742: # PRIVATE FCBLKS MAY HAVE ARBITRARY CONTENTS AND SPITBOL
743: # STORES NOTHING IN THEM.
744: #page
745: # THE REQUESTED SIZE FOR AN FCBLK IN DYNAMIC MEMORY
746: # SHOULD ALLOW A 2 WORD OVERHEAD FOR BLOCK TYPE AND
747: # LENGTH FIELDS. INFORMATION SUBSEQUENTLY STORED IN THE
748: # REMAINING WORDS MAY BE ARBITRARY IF AN XNBLK (EXTERNAL
749: # NON-RELOCATABLE BLOCK) IS REQUESTED. IF THE REQUEST IS
750: # FOR AN XRBLK (EXTERNAL RELOCATABLE BLOCK) THE
751: # CONTENTS OF WORDS SHOULD BE COLLECTABLE (I.E. ANY
752: # APPARENT POINTERS INTO DYNAMIC SHOULD BE GENUINE BLOCK
753: # POINTERS). THESE RESTRICTIONS DO NOT APPLY IF AN FCBLK
754: # IS ALLOCATED OUTSIDE DYNAMIC OR IS NOT ALLOCATED AT ALL.
755: # IF AN FCBLK IS REQUESTED, ITS FIELDS WILL BE INITIALISED
756: # TO ZERO BEFORE ENTRY TO SYSIO WITH THE EXCEPTION OF
757: # WORDS 0 AND 1 IN WHICH THE BLOCK TYPE AND LENGTH
758: # FIELDS ARE PLACED FOR FCBLKS IN DYNAMIC MEMORY ONLY.
759: # FOR THE POSSIBLE USE OF SYSEJ AND SYSXI, IF FCBLKS
760: # ARE USED, A CHAIN IS BUILT SO THAT THEY MAY ALL BE
761: # FOUND - SEE SYSXI FOR DETAILS.
762: # IF BOTH FILE ARG1 AND FILE ARG2 ARE NULL, CALLS OF SYSFC
763: # AND SYSIO ARE OMITTED.
764: # IF FILE ARG1 IS NULL (STANDARD INPUT/OUTPUT FILE), SYSFC
765: # IS CALLED TO CHECK NON-NULL FILE ARG2 BUT ANY REQUEST
766: # FOR AN FCBLK WILL BE IGNORED, SINCE SPITBOL HANDLES THE
767: # STANDARD FILES SPECIALLY AND CANNOT READILY KEEP FCBLK
768: # POINTERS FOR THEM.
769: # FILEARG1 IS TYPE CHECKED BY SPITBOL SO FURTHER CHECKING
770: # MAY BE UNNECCESSARY IN MANY IMPLEMENTATIONS.
771: # FILE ARG2 IS PASSED SO THAT SYSFC MAY ANALYSE AND
772: # CHECK IT. HOWEVER TO ASSIST IN THIS, SPITBOL ALSO PASSES
773: # ON THE STACK THE COMPONENTS OF THIS ARGUMENT WITH
774: # FILE NAME, $F$ (OTHERWISE NULL) EXTRACTED AND STACKED
775: # FIRST.
776: # THE OTHER FIELDS, IF ANY, ARE EXTRACTED AS SUBSTRINGS,
777: # POINTERS TO THEM ARE STACKED AND A COUNT OF ALL ITEMS
778: # STACKED IS PLACED IN WC. IF AN FCBLK WAS EARLIER
779: # ALLOCATED AND POINTED TO VIA FILE ARG1, SYSFC IS ALSO
780: # PASSED A POINTER TO THIS FCBLK.
781: #
782: # (XL) FILE ARG1 SCBLK PTR (2ND ARG)
783: # (XR) FILEARG2 (3RD ARG) OR NULL
784: # -(XS)...-(XS) SCBLKS FOR $F$,$R$,$C$,...
785: # (WC) NO. OF STACKED SCBLKS ABOVE
786: # (WA) EXISTING FILE ARG1 FCBLK PTR OR 0
787: # (WB) 0/3 FOR INPUT/OUTPUT ASSOCN
788: # JSR SYSFC CALL TO CHECK NEED FOR FCBLK
789: # PPM LOC INVALID FILE ARGUMENT
790: # (XS) POPPED (WC) TIMES
791: # (WA NON ZERO) BYTE SIZE OF REQUESTED FCBLK
792: # (WA=0,XL NON ZERO) PRIVATE FCBLK PTR IN XL
793: # (WA=XL=0) NO FCBLK WANTED, NO PRIVATE FCBLK
794: # (WC) 0/1/2 REQUEST ALLOC OF XRBLK/XNBLK
795: # /STATIC BLOCK FOR USE AS FCBLK
796: # (WB) DESTROYED
797: #page
798: #
799: # SYSHS -- GIVE ACCESS TO HOST COMPUTER FEATURES
800: #
801: .globl syshs # define external entry point
802: #
803: # PROVIDES MEANS FOR IMPLEMENTING SPECIAL FEATURES
804: # ON DIFFERENT HOST COMPUTERS. THE ONLY DEFINED ENTRY IS
805: # THAT WHERE ALL ARGUMENTS ARE NULL IN WHICH CASE SYSHS
806: # RETURNS AN SCBLK CONTAINING NAME OF COMPUTER,
807: # NAME OF OPERATING SYSTEM AND NAME OF SITE SEPARATED BY
808: # COLONS. THE SCBLK NEED NOT HAVE A CORRECT FIRST FIELD
809: # AS THIS IS SUPPLIED ON COPYING STRING TO DYNAMIC MEMORY.
810: # SPITBOL DOES NO ARGUMENT CHECKING BUT DOES PROVIDE A
811: # SINGLE ERROR RETURN FOR ARGUMENTS CHECKED AS ERRONEOUS
812: # BY OSINT. IT ALSO PROVIDES A SINGLE EXECUTION ERROR
813: # RETURN. IF THESE ARE INADEQUATE, USE MAY BE MADE OF THE
814: # MINIMAL ERROR SECTION DIRECT AS DESCRIBED IN MINIMAL
815: # DOCUMENTATION, SECTION 10.
816: # SEVERAL NON-ERROR RETURNS ARE PROVIDED. THE FIRST
817: # CORRESPONDS TO THE DEFINED ENTRY OR, FOR IMPLEMENTATION
818: # DEFINED ENTRIES, ANY STRING MAY BE RETURNED. THE OTHERS
819: # PERMIT RESPECTIVELY, RETURN A NULL RESULT, RETURN WITH A
820: # RESULT TO BE STACKED WHICH IS POINTED AT BY XR, AND A
821: # RETURN CAUSING SPITBOL STATEMENT FAILURE. IF A RETURNED
822: # RESULT IS IN DYNAMIC MEMORY IT MUST OBEY GARBAGE
823: # COLLECTOR RULES. THE ONLY RESULTS COPIED ON RETURN
824: # ARE STRINGS RETURNED VIA PPM LOC3 RETURN.
825: #
826: # (WA) ARGUMENT 1
827: # (XL) ARGUMENT 2
828: # (XR) ARGUMENT 3
829: # JSR SYSHS CALL TO GET HOST INFORMATION
830: # PPM LOC1 ERRONEOUS ARG
831: # PPM LOC2 EXECUTION ERROR
832: # PPM LOC3 SCBLK PTR IN XL OR 0 IF UNAVAILABLE
833: # PPM LOC4 RETURN A NULL RESULT
834: # PPM LOC5 RETURN RESULT IN XR
835: # PPM LOC6 CAUSE STATEMENT FAILURE
836: #page
837: #
838: # SYSID -- RETURN SYSTEM IDENTIFICATION
839: #
840: .globl sysid # define external entry point
841: #
842: # THIS ROUTINE SHOULD RETURN STRINGS TO HEAD THE STANDARD
843: # PRINTER OUTPUT. THE FIRST STRING WILL BE APPENDED TO
844: # A HEADING LINE OF THE FORM
845: # MACRO SPITBOL VERSION V.V
846: # SUPPLIED BY SPITBOL ITSELF. V.V ARE DIGITS GIVING THE
847: # MAJOR VERSION NUMBER AND GENERALLY AT LEAST A MINOR
848: # VERSION NUMBER RELATING TO OSINT SHOULD BE SUPPLIED TO
849: # GIVE SAY
850: # MACRO SPITBOL VERSION V.V(M.M)
851: # THE SECOND STRING SHOULD IDENTIFY AT LEAST THE MACHINE
852: # AND OPERATING SYSTEM. PREFERABLY IT SHOULD INCLUDE
853: # THE DATE AND TIME OF THE RUN.
854: # OPTIONALLY THE STRINGS MAY INCLUDE SITE NAME OF THE
855: # THE IMPLEMENTOR AND/OR MACHINE ON WHICH RUN TAKES PLACE,
856: # UNIQUE SITE OR COPY NUMBER AND OTHER INFORMATION AS
857: # APPROPRIATE WITHOUT MAKING IT SO LONG AS TO BE A
858: # NUISANCE TO USERS.
859: # THE FIRST WORDS OF THE SCBLKS POINTED AT NEED NOT BE
860: # CORRECTLY SET.
861: #
862: # JSR SYSID CALL FOR SYSTEM IDENTIFICATION
863: # (XR) SCBLK PTR FOR ADDITION TO HEADER
864: # (XL) PTR TO SECOND HEADER SCBLK
865: #page
866: #
867: # SYSIL -- GET INPUT RECORD LENGTH
868: #
869: .globl sysil # define external entry point
870: #
871: # SYSIL IS USED TO GET THE LENGTH OF THE NEXT INPUT RECORD
872: # FROM A FILE PREVIOUSLY INPUT ASSOCIATED WITH A SYSIO
873: # CALL. THE LENGTH RETURNED IS USED TO ESTABLISH A BUFFER
874: # FOR A SUBSEQUENT SYSIN CALL.
875: #
876: # (WA) PTR TO FCBLK OR ZERO
877: # JSR SYSIL CALL TO GET RECORD LENGTH
878: # (WA) LENGTH OR ZERO IF FILE CLOSED
879: #
880: # NO HARM IS DONE IF THE VALUE RETURNED IS TOO LONG SINCE
881: # UNUSED SPACE WILL BE RECLAIMED AFTER THE SYSIN CALL.
882: #
883: # NOTE THAT IT IS THE SYSIL CALL (NOT THE SYSIO CALL) WHICH
884: # CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST
885: # RECORD INPUT FROM THE FILE.
886: #page
887: #
888: # SYSIN -- READ INPUT RECORD
889: #
890: .globl sysin # define external entry point
891: #
892: # SYSIN IS USED TO READ A RECORD FROM THE FILE WHICH WAS
893: # REFERENCED IN A PRIOR CALL TO SYSIL (I.E. THESE CALLS
894: # ALWAYS OCCUR IN PAIRS). THE BUFFER PROVIDED IS AN
895: # SCBLK FOR A STRING OF LENGTH SET FROM THE SYSIL CALL.
896: # IF THE ACTUAL LENGTH READ IS LESS THAN THIS, THE LENGTH
897: # FIELD OF THE SCBLK MUST BE MODIFIED BEFORE RETURNING
898: # UNLESS BUFFER IS RIGHT PADDED WITH ZEROES.
899: # IT IS ALSO PERMISSIBLE TO TAKE ANY OF THE ALTERNATIVE
900: # RETURNS AFTER SCBLK LENGTH HAS BEEN MODIFIED.
901: #
902: # (WA) PTR TO FCBLK OR ZERO
903: # (XR) POINTER TO BUFFER (SCBLK PTR)
904: # JSR SYSIN CALL TO READ RECORD
905: # PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI
906: # PPM LOC RETURN HERE IF I/O ERROR
907: # PPM LOC RETURN HERE IF RECORD FORMAT ERROR
908: # (WA,WB,WC) DESTROYED
909: #page
910: #
911: # SYSIO -- INPUT/OUTPUT FILE ASSOCIATION
912: #
913: .globl sysio # define external entry point
914: #
915: # SEE ALSO SYSFC.
916: # SYSIO IS CALLED IN RESPONSE TO A SNOBOL4 INPUT OR OUTPUT
917: # FUNCTION CALL EXCEPT WHEN FILE ARG1 AND FILE ARG2
918: # ARE BOTH NULL.
919: # ITS CALL ALWAYS FOLLOWS IMMEDIATELY AFTER A CALL
920: # OF SYSFC. IF SYSFC REQUESTED ALLOCATION
921: # OF AN FCBLK, ITS ADDRESS WILL BE IN WA.
922: # FOR INPUT FILES, NON-ZERO VALUES OF $R$ SHOULD BE
923: # COPIED TO WC FOR USE IN ALLOCATING INPUT BUFFERS. IF $R$
924: # IS DEFAULTED OR NOT IMPLEMENTED, WC SHOULD BE ZEROISED.
925: # ONCE A FILE HAS BEEN OPENED, SUBSEQUENT INPUT(),OUTPUT()
926: # CALLS IN WHICH THE SECOND ARGUMENT IS IDENTICAL WITH THAT
927: # IN A PREVIOUS CALL, MERELY ASSOCIATE THE ADDITIONAL
928: # VARIABLE NAME (FIRST ARGUMENT) TO THE FILE AND DO NOT
929: # RESULT IN RE-OPENING THE FILE.
930: # IN SUBSEQUENT ASSOCIATED ACCESSES TO THE FILE A POINTER
931: # TO ANY FCBLK ALLOCATED WILL BE MADE AVAILABLE.
932: #
933: # (XL) FILE ARG1 SCBLK PTR (2ND ARG)
934: # (XR) FILE ARG2 SCBLK PTR (3RD ARG)
935: # (WA) FCBLK PTR (0 IF NONE)
936: # (WB) 0 FOR INPUT, 3 FOR OUTPUT
937: # JSR SYSIO CALL TO ASSOCIATE FILE
938: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST
939: # PPM LOC RETURN IF INPUT/OUTPUT NOT ALLOWED
940: # (XL) FCBLK POINTER (0 IF NONE)
941: # (WC) 0 (FOR DEFAULT) OR MAX RECORD LNGTH
942: # (WA,WB) DESTROYED
943: #
944: # THE SECOND ERROR RETURN IS USED IF THE FILE NAMED EXISTS
945: # BUT INPUT/OUTPUT FROM THE FILE IS NOT ALLOWED. FOR
946: # EXAMPLE, THE STANDARD OUTPUT FILE MAY BE IN THIS CATEGORY
947: # AS REGARDS INPUT ASSOCIATION.
948: #page
949: #
950: # SYSLD -- LOAD EXTERNAL FUNCTION
951: #
952: .globl sysld # define external entry point
953: #
954: # SYSLD IS CALLED IN RESPONSE TO THE USE OF THE SNOBOL4
955: # LOAD FUNCTION. THE NAMED FUNCTION IS LOADED (WHATEVER
956: # THIS MEANS), AND A POINTER IS RETURNED. THE POINTER WILL
957: # BE USED ON SUBSEQUENT CALLS TO THE FUNCTION (SEE SYSEX).
958: #
959: # (XR) POINTER TO FUNCTION NAME (SCBLK)
960: # (XL) POINTER TO LIBRARY NAME (SCBLK)
961: # JSR SYSLD CALL TO LOAD FUNCTION
962: # PPM LOC RETURN HERE IF FUNC DOES NOT EXIST
963: # PPM LOC RETURN HERE IF I/O ERROR
964: # (XR) POINTER TO LOADED CODE
965: #
966: # THE SIGNIFICANCE OF THE POINTER RETURNED IS UP TO THE
967: # SYSTEM INTERFACE ROUTINE. THE ONLY RESTRICTION IS THAT
968: # IF THE POINTER IS WITHIN DYNAMIC STORAGE, IT MUST BE
969: # A PROPER BLOCK POINTER.
970: #page
971: #
972: # SYSMM -- GET MORE MEMORY
973: #
974: .globl sysmm # define external entry point
975: #
976: # SYSMM IS CALLED IN AN ATTEMPT TO ALLOCATE MORE DYNAMIC
977: # MEMORY. THIS MEMORY MUST BE ALLOCATED CONTIGUOUSLY WITH
978: # THE CURRENT DYNAMIC DATA AREA.
979: #
980: # THE AMOUNT ALLOCATED IS UP TO THE SYSTEM TO DECIDE. ANY
981: # VALUE IS ACCEPTABLE INCLUDING ZERO IF ALLOCATION IS
982: # IMPOSSIBLE.
983: #
984: # JSR SYSMM CALL TO GET MORE MEMORY
985: # (XR) NUMBER OF ADDITIONAL WORDS OBTAINED
986: #page
987: #
988: # SYSMX -- SUPPLY MXLEN
989: #
990: .globl sysmx # define external entry point
991: #
992: # BECAUSE OF THE METHOD OF GARBAGE COLLECTION, NO SPITBOL
993: # OBJECT IS ALLOWED TO OCCUPY MORE BYTES OF MEMORY THAN
994: # THE INTEGER GIVING THE LOWEST ADDRESS OF DYNAMIC
995: # (GARBAGE COLLECTABLE) MEMORY. MXLEN IS THE NAME USED TO
996: # REFER TO THIS MAXIMUM LENGTH OF AN OBJECT AND FOR MOST
997: # USERS OF MOST IMPLEMENTATIONS, PROVIDED DYNAMIC MEMORY
998: # STARTS AT AN ADDRESS OF AT LEAST A FEW THOUSAND WORDS,
999: # THERE IS NO PROBLEM.
1000: # IF THE DEFAULT STARTING ADDRESS IS LESS THAN SAY 10000 OR
1001: # 20000, THEN A LOAD TIME OPTION SHOULD BE PROVIDED WHERE A
1002: # USER CAN REQUEST THAT HE BE ABLE TO CREATE LARGER
1003: # OBJECTS. THIS ROUTINE INFORMS SPITBOL OF THIS REQUEST IF
1004: # ANY. THE VALUE RETURNED IS EITHER AN INTEGER
1005: # REPRESENTING THE DESIRED VALUE OF MXLEN (AND HENCE THE
1006: # MINIMUM DYNAMIC STORE ADDRESS WHICH MAY RESULT IN
1007: # NON-USE OF SOME STORE) OR ZERO IF A DEFAULT IS ACCEPTABLE
1008: # IN WHICH MXLEN IS SET TO THE LOWEST ADDRESS ALLOCATED
1009: # TO DYNAMIC STORE BEFORE COMPILATION STARTS.
1010: # IF A NON-ZERO VALUE IS RETURNED, THIS IS USED FOR KEYWORD
1011: # MAXLNGTH. OTHERWISE THE INITIAL LOW ADDRESS OF DYNAMIC
1012: # MEMORY IS USED FOR THIS KEYWORD.
1013: #
1014: # JSR SYSMX CALL TO GET MXLEN
1015: # (WA) EITHER MXLEN OR 0 FOR DEFAULT
1016: #page
1017: #
1018: # SYSOU -- OUTPUT RECORD
1019: #
1020: .globl sysou # define external entry point
1021: #
1022: # SYSOU IS USED TO WRITE A RECORD TO A FILE PREVIOUSLY
1023: # ASSOCIATED WITH A SYSIO CALL.
1024: #
1025: # (WA) PTR TO FCBLK OR ZERO
1026: # (XR) RECORD TO BE WRITTEN (SCBLK)
1027: # JSR SYSOU CALL TO OUTPUT RECORD
1028: # PPM LOC FILE FULL OR NO FILE AFTER SYSXI
1029: # PPM LOC RETURN HERE IF I/O ERROR
1030: # (WA,WB,WC) DESTROYED
1031: #
1032: # NOTE THAT IT IS THE SYSOU CALL (NOT THE SYSIO CALL) WHICH
1033: # CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST
1034: # RECORD OUTPUT TO THE FILE.
1035: #page
1036: #
1037: # SYSPI -- PRINT ON INTERACTIVE CHANNEL
1038: #
1039: .globl syspi # define external entry point
1040: #
1041: # IF SPITBOL IS RUN FROM AN ONLINE TERMINAL, OSINT CAN
1042: # REQUEST THAT MESSAGES SUCH AS COPIES OF COMPILATION
1043: # ERRORS BE SENT TO THE TERMINAL (SEE SYSPP). IF RELEVANT
1044: # REPLY WAS MADE BY SYSPP THEN SYSPI IS CALLED TO SEND SUCH
1045: # MESSAGES TO THE INTERACTIVE CHANNEL.
1046: # SYSPI IS ALSO USED FOR SENDING OUTPUT TO THE TERMINAL
1047: # THROUGH THE SPECIAL VARIABLE NAME, TERMINAL.
1048: #
1049: # (XR) PTR TO LINE BUFFER (SCBLK)
1050: # (WA) LINE LENGTH
1051: # JSR SYSPI CALL TO PRINT LINE
1052: # PPM LOC FAILURE RETURN
1053: # (WA,WB) DESTROYED
1054: #page
1055: #
1056: # SYSPP -- OBTAIN PRINT PARAMETERS
1057: #
1058: .globl syspp # define external entry point
1059: #
1060: # SYSPP IS CALLED ONCE DURING COMPILATION TO OBTAIN
1061: # PARAMETERS REQUIRED FOR CORRECT PRINTED OUTPUT FORMAT
1062: # AND TO SELECT OTHER OPTIONS. IT MAY ALSO BE CALLED AGAIN
1063: # AFTER SYSXI WHEN A LOAD MODULE IS RESUMED. IN THIS
1064: # CASE THE VALUE RETURNED IN WA MAY BE LESS THAN OR EQUAL
1065: # TO THAT RETURNED IN INITIAL CALL BUT MAY NOT BE
1066: # GREATER.
1067: # THE INFORMATION RETURNED IS -
1068: # 1. LINE LENGTH IN CHARS FOR STANDARD PRINT FILE
1069: # 2. NO OF LINES/PAGE. 0 IS PREFERABLE FOR A NON-PAGED
1070: # DEVICE (E.G. ONLINE TERMINAL) IN WHICH CASE LISTING
1071: # PAGE THROWS ARE SUPPRESSED AND PAGE HEADERS
1072: # RESULTING FROM -TITLE,-STITL LINES ARE KEPT SHORT.
1073: # 3. AN INITIAL -NOLIST OPTION TO SUPPRESS LISTING UNLESS
1074: # THE PROGRAM CONTAINS AN EXPLICIT -LIST.
1075: # 4. OPTIONS TO SUPPRESS LISTING OF COMPILATION AND/OR
1076: # EXECUTION STATS (USEFUL FOR ESTABLISHED PROGRAMS) -
1077: # COMBINED WITH 3. GIVES POSSIBILITY OF LISTING
1078: # FILE NEVER BEING OPENED.
1079: # 5. OPTION TO HAVE COPIES OF ERRORS SENT TO AN
1080: # INTERACTIVE CHANNEL IN ADDITION TO STANDARD PRINTER.
1081: # 6. OPTION TO KEEP PAGE HEADERS SHORT (E.G. IF LISTING
1082: # TO AN ONLINE TERMINAL).
1083: # 7. AN OPTION TO CHOOSE EXTENDED OR COMPACT LISTING
1084: # FORMAT. IN THE FORMER A PAGE EJECT AND IN THE LATTER
1085: # A FEW LINE FEEDS PRECEDE THE PRINTING OF EACH
1086: # OF-- LISTING, COMPILATION STATISTICS, EXECUTION
1087: # OUTPUT AND EXECUTION STATISTICS.
1088: # 8. AN OPTION TO SUPPRESS EXECUTION AS THOUGH A
1089: # -NOEXECUTE CARD WERE SUPPLIED.
1090: # 9. AN OPTION TO REQUEST THAT NAME /TERMINAL/ BE PRE-
1091: # ASSOCIATED TO AN ONLINE TERMINAL VIA SYSPI AND SYSRI
1092: # 10. AN INTERMEDIATE (STANDARD) LISTING OPTION REQUIRING
1093: # THAT PAGE EJECTS OCCUR IN SOURCE LISTINGS. REDUNDANT
1094: # IF EXTENDED OPTION CHOSEN BUT PARTIALLY EXTENDS
1095: # COMPACT OPTION.
1096: # 11. OPTION TO SUPPRESS SYSID IDENTIFICATION.
1097: #
1098: # JSR SYSPP CALL TO GET PRINT PARAMETERS
1099: # (WA) PRINT LINE LENGTH IN CHARS
1100: # (WB) NUMBER OF LINES/PAGE
1101: # (WC) BITS VALUE ...JIHGFEDCBA WHERE
1102: # A = 1 TO SEND ERROR COPY TO INT.CH.
1103: # B = 1 MEANS STD PRINTER IS INT. CH.
1104: # C = 1 FOR -NOLIST OPTION
1105: # D = 1 TO SUPPRESS COMPILN. STATS
1106: # E = 1 TO SUPPRESS EXECN. STATS
1107: # F = 1/0 FOR EXTNDED/COMPACT LISTING
1108: # G = 1 FOR -NOEXECUTE
1109: # H = 1 PRE-ASSOCIATE /TERMINAL/
1110: # I = 1 FOR STANDARD LISTING OPTION.
1111: # J = 1 SUPPRESSES LISTING HEADER
1112: #page
1113: #
1114: # SYSPR -- PRINT LINE ON STANDARD OUTPUT FILE
1115: #
1116: .globl syspr # define external entry point
1117: #
1118: # SYSPR IS USED TO PRINT A SINGLE LINE ON THE STANDARD
1119: # OUTPUT FILE.
1120: #
1121: # (XR) POINTER TO LINE BUFFER (SCBLK)
1122: # (WA) LINE LENGTH
1123: # JSR SYSPR CALL TO PRINT LINE
1124: # PPM LOC TOO MUCH O/P OR NO FILE AFTER SYSXI
1125: # (WA,WB) DESTROYED
1126: #
1127: # THE BUFFER POINTED TO IS THE LENGTH OBTAINED FROM THE
1128: # SYSPP CALL AND IS FILLED OUT WITH TRAILING BLANKS. THE
1129: # VALUE IN WA IS THE ACTUAL LINE LENGTH WHICH MAY BE LESS
1130: # THAN THE MAXIMUM LINE LENGTH POSSIBLE. THERE IS NO SPACE
1131: # CONTROL ASSOCIATED WITH THE LINE, ALL LINES ARE PRINTED
1132: # SINGLE SPACED. NOTE THAT NULL LINES (WA=0) ARE POSSIBLE
1133: # IN WHICH CASE A BLANK LINE IS TO BE PRINTED.
1134: #
1135: # THE ERROR EXIT IS USED FOR SYSTEMS WHICH LIMIT THE AMOUNT
1136: # OF PRINTED OUTPUT. IF POSSIBLE, PRINTING SHOULD BE
1137: # PERMITTED AFTER THIS CONDITION HAS BEEN SIGNALLED ONCE TO
1138: # ALLOW FOR DUMP AND OTHER DIAGNOSTIC INFORMATION.
1139: # ASSUMING THIS TO BE POSSIBLE, SPITBOL MAY MAKE MORE SYSPR
1140: # CALLS. IF THE ERROR RETURN OCCURS ANOTHER TIME, EXECUTION
1141: # IS TERMINATED BY A CALL OF SYSEJ WITH ENDING CODE 998.
1142: #page
1143: #
1144: # SYSRD -- READ RECORD FROM STANDARD INPUT FILE
1145: #
1146: .globl sysrd # define external entry point
1147: #
1148: # SYSRD IS USED TO READ A RECORD FROM THE STANDARD INPUT
1149: # FILE. THE BUFFER PROVIDED IS AN SCBLK FOR A STRING THE
1150: # LENGTH OF WHICH IN CHARACTERS IS GIVEN IN WC, THIS
1151: # CORRESPONDING TO THE MAXIMUM LENGTH OF STRING WHICH
1152: # SPITBOL IS PREPARED TO RECEIVE. AT COMPILE TIME IT
1153: # CORRESPONDS TO XXX IN THE MOST RECENT -INXXX CARD
1154: # (DEFAULT 72) AND AT EXECUTION TIME TO THE MOST RECENT
1155: # ,R$R$ (RECORD LENGTH) IN THE THIRD ARG OF AN INPUT()
1156: # STATEMENT FOR THE STANDARD INPUT FILE (DEFAULT 80).
1157: # IF FEWER THAN (WC) CHARACTERS ARE READ, THE LENGTH
1158: # FIELD OF THE SCBLK MUST BE ADJUSTED BEFORE RETURNING
1159: # UNLESS THE BUFFER IS RIGHT PADDED WITH ZEROES.
1160: # IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE RETURN
1161: # AFTER SUCH AN ADJUSTMENT HAS BEEN MADE.
1162: # SPITBOL MAY CONTINUE TO MAKE CALLS AFTER AN ENDFILE
1163: # RETURN SO THIS ROUTINE SHOULD BE PREPARED TO MAKE
1164: # REPEATED ENDFILE RETURNS.
1165: #
1166: # (XR) POINTER TO BUFFER (SCBLK PTR)
1167: # (WC) LENGTH OF BUFFER IN CHARACTERS
1168: # JSR SYSRD CALL TO READ LINE
1169: # PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI
1170: # (WA,WB,WC) DESTROYED
1171: #page
1172: #
1173: # SYSRI -- READ RECORD FROM INTERACTIVE CHANNEL
1174: #
1175: .globl sysri # define external entry point
1176: #
1177: # READS A RECORD FROM ONLINE TERMINAL FOR SPITBOL VARIABLE,
1178: # TERMINAL. IF ONLINE TERMINAL IS UNAVAILABLE THEN CODE THE
1179: # ENDFILE RETURN ONLY.
1180: # THE BUFFER PROVIDED IS OF LENGTH 120 CHARACTERS. SYSRI
1181: # SHOULD REPLACE THE COUNT IN THE SECOND WORD OF THE SCBLK
1182: # BY THE ACTUAL CHARACTER COUNT UNLESS BUFFER IS RIGHT
1183: # PADDED WITH ZEROES.
1184: # IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE
1185: # RETURN AFTER ADJUSTING THE COUNT.
1186: # THE END OF FILE RETURN MAY BE USED IF THIS MAKES
1187: # SENSE ON THE TARGET MACHINE (E.G. IF THERE IS AN
1188: # EOF CHARACTER.)
1189: #
1190: # (XR) PTR TO 120 CHAR BUFFER (SCBLK PTR)
1191: # JSR SYSRI CALL TO READ LINE FROM TERMINAL
1192: # PPM LOC END OF FILE RETURN
1193: # (WA,WB,WC) MAY BE DESTROYED
1194: #page
1195: #
1196: # SYSRW -- REWIND FILE
1197: #
1198: .globl sysrw # define external entry point
1199: #
1200: # SYSRW IS USED TO REWIND A FILE I.E. REPOSITION THE FILE
1201: # AT THE START BEFORE THE FIRST RECORD. THE FILE SHOULD BE
1202: # CLOSED AND THE NEXT READ OR WRITE CALL WILL OPEN THE
1203: # FILE AT THE START.
1204: #
1205: # (WA) PTR TO FCBLK OR ZERO
1206: # (XR) REWIND ARG (SCBLK PTR)
1207: # JSR SYSRW CALL TO REWIND FILE
1208: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST
1209: # PPM LOC RETURN HERE IF REWIND NOT ALLOWED
1210: # PPM LOC RETURN HERE IF I/O ERROR
1211: #page
1212: #
1213: # SYSST -- SET FILE POINTER
1214: #
1215: .globl sysst # define external entry point
1216: #
1217: # SYSST IS CALLED TO CHANGE THE POSITION OF A FILE
1218: # POINTER. THIS IS ACCOMPLISHED IN A SYSTEM DEPENDENT
1219: # MANNER, AND THUS THE 2ND AND 3RD ARGUMENTS ARE PASSED
1220: # UNCONVERTED.
1221: #
1222: # (WA) FCBLK POINTER
1223: # (WB) 2ND ARGUMENT
1224: # (WC) 3RD ARGUMENT
1225: # JSR SYSST CALL TO SET FILE POINTER
1226: # PPM LOC RETURN HERE IF INVALID 2ND ARG
1227: # PPM LOC RETURN HERE IF INVALID 3RD ARG
1228: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST
1229: # PPM LOC RETURN HERE IF SET NOT ALLOWED
1230: # PPM LOC RETURN HERE IF I/O ERROR
1231: #
1232: #page
1233: #
1234: # SYSTM -- GET EXECUTION TIME SO FAR
1235: #
1236: .globl systm # define external entry point
1237: #
1238: # SYSTM IS USED TO OBTAIN THE AMOUNT OF EXECUTION TIME
1239: # USED SO FAR SINCE SPITBOL WAS GIVEN CONTROL. THE UNITS
1240: # ARE DESCRIBED AS MILLISECONDS IN THE SPITBOL OUTPUT, BUT
1241: # THE EXACT MEANING IS SYSTEM DEPENDENT. WHERE APPROPRIATE,
1242: # THIS VALUE SHOULD RELATE TO PROCESSOR RATHER THAN CLOCK
1243: # TIMING VALUES.
1244: #
1245: # JSR SYSTM CALL TO GET TIMER VALUE
1246: # (IA) TIME SO FAR IN MILLISECONDS
1247: #page
1248: #
1249: # SYSTT -- TRACE TOGGLE
1250: #
1251: .globl systt # define external entry point
1252: #
1253: # CALLED BY SPITBOL FUNCTION TRACE() WITH NO ARGS TO
1254: # TOGGLE THE SYSTEM TRACE SWITCH. THIS PERMITS TRACING OF
1255: # LABELS IN SPITBOL CODE TO BE TURNED ON OR OFF.
1256: #
1257: # JSR SYSTT CALL TO TOGGLE TRACE SWITCH
1258: #page
1259: #
1260: # SYSUL -- UNLOAD EXTERNAL FUNCTION
1261: #
1262: .globl sysul # define external entry point
1263: #
1264: # SYSUL IS USED TO UNLOAD A FUNCTION PREVIOUSLY
1265: # LOADED WITH A CALL TO SYSLD.
1266: #
1267: # (XR) PTR TO CONTROL BLOCK (EFBLK)
1268: # JSR SYSUL CALL TO UNLOAD FUNCTION
1269: #
1270: # THE FUNCTION CANNOT BE CALLED FOLLOWING A SYSUL CALL
1271: # UNTIL ANOTHER SYSLD CALL IS MADE FOR THE SAME FUNCTION.
1272: #
1273: # THE EFBLK CONTAINS THE FUNCTION CODE POINTER AND ALSO A
1274: # POINTER TO THE VRBLK CONTAINING THE FUNCTION NAME (SEE
1275: # DEFINITIONS AND DATA STRUCTURES SECTION).
1276: #page
1277: #
1278: # SYSXI -- EXIT TO PRODUCE LOAD MODULE
1279: #
1280: .globl sysxi # define external entry point
1281: #
1282: # WHEN SYSXI IS CALLED, XL CONTAINS EITHER A STRING POINTER
1283: # OR ZERO. IN THE FORMER CASE, THE STRING GIVES THE
1284: # CHARACTER NAME OF A PROGRAM. THE INTENTION IS THAT
1285: # SPITBOL EXECUTION SHOULD BE TERMINATED FORTHWITH AND
1286: # THE NAMED PROGRAM LOADED AND EXECUTED. THIS TYPE OF CHAIN
1287: # EXECUTION IS VERY SYSTEM DEPENDENT AND IMPLEMENTORS MAY
1288: # CHOOSE TO OMIT IT OR FIND IT IMPOSSIBLE TO PROVIDE.
1289: # IF (XL) IS ZERO,IA CONTAINS ONE OF THE FOLLOWING INTEGERS
1290: #
1291: # -1, -2, -3
1292: # CREATE IF POSSIBLE A LOAD MODULE CONTAINING ONLY THE
1293: # IMPURE AREA OF MEMORY WHICH NEEDS TO BE LOADED WITH
1294: # A COMPATIBLE PURE SEGMENT FOR SUBSEQUENT EXECUTIONS.
1295: # VERSION NUMBERS TO CHECK COMPATIBILITY SHOULD BE
1296: # KEPT IN BOTH SEGMENTS AND CHECKED ON LOADING.
1297: # TO ASSIST WITH THIS CHECK, (XR) ON ENTRY IS A
1298: # POINTER TO AN SCBLK CONTAINING THE SPITBOL MAJOR
1299: # VERSION NUMBER V.V (SEE SYSID).
1300: #
1301: # 0 IF POSSIBLE, RETURN CONTROL TO JOB CONTROL
1302: # COMMAND LEVEL. THE EFFECT IF AVAILABLE WILL BE
1303: # SYSTEM DEPENDENT.
1304: #
1305: # +1, +2, +3
1306: # CREATE IF POSSIBLE A LOAD MODULE FROM ALL OF
1307: # MEMORY. IT SHOULD BE POSSIBLE TO LOAD AND EXECUTE
1308: # THIS MODULE DIRECTLY.
1309: #
1310: # IN THE CASE OF SAVED LOAD MODULES, THE STATUS OF OPEN
1311: # FILES IS NOT PRESERVED AND IMPLEMENTORS MAY CHOOSE TO
1312: # OFFER MEANS OF ATTACHING FILES BEFORE EXECUTION OF LOAD
1313: # MODULES STARTS OR LEAVE IT TO THE USER TO INCLUDE
1314: # SUITABLE INPUT(), OUTPUT() CALLS IN HIS PROGRAM.
1315: # SYSXI SHOULD MAKE A NOTE THAT NO I/O CHANNELS,
1316: # INCLUDING STANDARD FILES, HAVE FILES ATTACHED SO THAT
1317: # CALLS OF SYSIN, SYSOU, SYSPR, SYSRD SHOULD FAIL UNLESS
1318: # NEW ASSOCIATIONS ARE MADE FOR THE LOAD MODULE.
1319: # AT LEAST IN THE CASE OF THE STANDARD OUTPUT FILE, IT IS
1320: # RECOMMENDED THAT EITHER THE USER BE REQUIRED TO ATTACH
1321: # A FILE OR THAT A DEFAULT FILE IS ATTACHED, SINCE THE
1322: # PROBLEM OF ERROR MESSAGES GENERATED BY THE LOAD MODULE
1323: # IS OTHERWISE SEVERE. AS A LAST RESORT, IF SPITBOL
1324: # ATTEMPTS TO WRITE TO THE STANDARD OUTPUT FILE AND GETS A
1325: # REPLY INDICATING THAT SUCH OUPUT IS UNACCEPTABLE IT STOPS
1326: # BY USING AN ENTRY TO SYSEJ WITH ENDING CODE 998.
1327: # AS DESCRIBED BELOW, PASSING OF SOME ARGUMENTS MAKES IT
1328: # CLEAR THAT LOAD MODULE WILL USE A STANDARD OUTPUT FILE.
1329: #
1330: # IF USE IS MADE OF FCBLKS FOR I/O ASSOCIATION, SPITBOL
1331: # BUILDS A CHAIN SO THAT THOSE IN USE MAY BE FOUND IN SYSXI
1332: # AND SYSEJ. THE NODES ARE 4 WORDS LONG. THIRD WORD
1333: # CONTAINS LINK TO NEXT NODE OR 0, FOURTH WORD CONTAINS
1334: # FCBLK POINTER.
1335: #page
1336: #
1337: # SYSXI (CONTINUED)
1338: #
1339: # (XL) ZERO OR SCBLK PTR
1340: # (XR) PTR TO V.V SCBLK
1341: # (IA) SIGNED INTEGER ARGUMENT
1342: # (WB) 0 OR PTR TO HEAD OF FCBLK CHAIN
1343: # JSR SYSXI CALL TO EXIT
1344: # PPM LOC REQUESTED ACTION NOT POSSIBLE
1345: # PPM LOC ACTION CAUSED IRRECOVERABLE ERROR
1346: # (REGISTERS) SHOULD BE PRESERVED OVER CALL
1347: #
1348: # LOADING AND RUNNING THE LOAD MODULE OR RETURNING FROM
1349: # JCL COMMAND LEVEL CAUSES EXECUTION TO RESUME AT THE POINT
1350: # AFTER THE ERROR RETURNS WHICH FOLLOW THE CALL OF SYSXI.
1351: # THE VALUE PASSED AS EXIT ARGUMENT IS USED TO INDICATE
1352: # OPTIONS REQUIRED ON RESUMPTION OF LOAD MODULE.
1353: # +1 OR -1 REQUIRE THAT ON RESUMPTION, SYSID AND SYSPP BE
1354: # CALLED AND A HEADING PRINTED ON THE STANDARD OUTPUT FILE.
1355: # +2 OR -2 INDICATE THAT SYSPP WILL BE CALLED BUT NOT SYSID
1356: # AND NO HEADING WILL BE PUT ON STANDARD OUTPUT FILE.
1357: # ABOVE OPTIONS HAVE THE OBVIOUS IMPLICATION THAT A
1358: # STANDARD O/P FILE MUST BE PROVIDED FOR THE LOAD MODULE.
1359: # +3 OR -3 INDICATE CALLS OF NEITHER SYSID NOR SYSPP
1360: # AND NO HEADING WILL BE PLACED ON STANDARD OUTPUT FILE.
1361: # NO RETURN FROM SYSXI IS POSSIBLE IF ANOTHER PROGRAM
1362: # IS LOADED AND ENTERED.
1363: #page
1364: #
1365: # INTRODUCE THE INTERNAL PROCEDURES.
1366: #
1367: .globl acess
1368: .globl acomp
1369: .globl alloc
1370: .globl alobf
1371: .globl alocs
1372: .globl alost
1373: .globl apndb
1374: .globl arith
1375: .globl asign
1376: .globl asinp
1377: .globl blkln
1378: .globl cdgcg
1379: .globl cdgex
1380: .globl cdgnm
1381: .globl cdgvl
1382: .globl cdwrd
1383: .globl cmgen
1384: .globl cmpil
1385: .globl cncrd
1386: .globl copyb
1387: .globl dffnc
1388: .globl dtach
1389: .globl dtype
1390: .globl dumpr
1391: .globl ermsg
1392: .globl ertex
1393: .globl evali
1394: .globl evalp
1395: .globl evals
1396: .globl evalx
1397: .globl exbld
1398: .globl expan
1399: .globl expap
1400: .globl expdm
1401: .globl expop
1402: .globl flstg
1403: .globl gbcol
1404: .globl gbcpf
1405: .globl gtarr
1406: #page
1407: .globl gtcod
1408: .globl gtexp
1409: .globl gtint
1410: .globl gtnum
1411: .globl gtnvr
1412: .globl gtpat
1413: .globl gtrea
1414: .globl gtsmi
1415: .globl gtstg
1416: .globl gtvar
1417: .globl hashs
1418: .globl icbld
1419: .globl ident
1420: .globl inout
1421: .globl insbf
1422: .globl iofcb
1423: .globl ioppf
1424: .globl ioput
1425: .globl ktrex
1426: .globl kwnam
1427: .globl lcomp
1428: .globl listr
1429: .globl listt
1430: .globl nexts
1431: .globl patin
1432: .globl patst
1433: .globl pbild
1434: .globl pconc
1435: .globl pcopy
1436: .globl prflr
1437: .globl prflu
1438: .globl prpar
1439: .globl prtch
1440: .globl prtic
1441: .globl prtis
1442: .globl prtin
1443: .globl prtmi
1444: .globl prtmx
1445: .globl prtnl
1446: .globl prtnm
1447: .globl prtnv
1448: .globl prtpg
1449: .globl prtps
1450: .globl prtsn
1451: .globl prtst
1452: #page
1453: .globl prttr
1454: .globl prtvl
1455: .globl prtvn
1456: .globl rcbld
1457: .globl readr
1458: .globl sbstr
1459: .globl scane
1460: .globl scngf
1461: .globl setvr
1462: .globl sorta
1463: .globl sortc
1464: .globl sortf
1465: .globl sorth
1466: .globl tfind
1467: .globl trace
1468: .globl trbld
1469: .globl trimr
1470: .globl trxeq
1471: .globl xscan
1472: .globl xscni
1473: #
1474: # INTRODUCE THE INTERNAL ROUTINES
1475: #
1476: .globl arref
1477: .globl cfunc
1478: .globl exfal
1479: .globl exint
1480: .globl exits
1481: .globl exixr
1482: .globl exnam
1483: .globl exnul
1484: .globl exrea
1485: .globl exsid
1486: .globl exvnm
1487: .globl failp
1488: .globl flpop
1489: .globl indir
1490: .globl match
1491: .globl retrn
1492: .globl stcov
1493: .globl stmgo
1494: .globl stopr
1495: .globl succp
1496: .globl sysab
1497: .globl systu
1498: #title s p i t b o l -- definitions and data structures
1499: #sec # start of definitions section
1500: #
1501: # DEFINITIONS OF MACHINE PARAMETERS
1502: #
1503: # THE MINIMAL TRANSLATOR SHOULD SUPPLY APPROPRIATE VALUES
1504: # FOR THE PARTICULAR TARGET MACHINE FOR ALL THE
1505: # EQU *
1506: # DEFINITIONS GIVEN AT THE START OF THIS SECTION.
1507: #
1508: .set cfp$a,256 # number of characters in alphabet
1509: #
1510: .set cfp$b,4 # bytes/word addressing factor
1511: #
1512: .set cfp$c,4 # number of characters per word
1513: #
1514: .set cfp$f,8 # offset in bytes to chars in
1515: # SCBLK. SEE SCBLK FORMAT.
1516: #
1517: .set cfp$i,1 # number of words in integer constant
1518: #
1519: .set cfp$m,0x7fffffff# max positive integer in one word
1520: #
1521: .set cfp$n,32 # number of bits in one word
1522: #
1523: # THE FOLLOWING DEFINITIONS REQUIRE THE SUPPLY OF EITHER
1524: # A SINGLE PARAMETER IF REAL ARITHMETIC IS OMITTED OR
1525: # THREE PARAMETERS IF REAL ARITHMETIC IS INCLUDED.
1526: #
1527: #
1528: .set cfp$r,1 # number of words in real constant
1529: #
1530: .set cfp$s,6 # number of sig digs for real output
1531: #
1532: .set cfp$x,2 # max digits in real exponent
1533: #
1534: .set mxdgs,cfp$s+cfp$x# max digits in real number
1535: #
1536: .set nstmx,mxdgs+5 # max space for real (for +0.e+)
1537: #
1538: # THE FOLLOWING DEFINITION FOR CFP$U SUPPLIES A REALISTIC
1539: # UPPER BOUND ON THE SIZE OF THE ALPHABET. CFP$U IS USED
1540: # TO SAVE SPACE IN THE SCANE BSW-IFF-ESW TABLE AND TO EASE
1541: # TRANSLATION STORAGE REQUIREMENTS.
1542: #
1543: .set cfp$u,128 # realistic upper bound on alphabet
1544: #page
1545: #
1546: # ENVIRONMENT PARAMETERS
1547: #
1548: # THE SPITBOL PROGRAM IS ESSENTIALLY INDEPENDENT OF
1549: # THE DEFINITIONS OF THESE PARAMETERS. HOWEVER, THE
1550: # EFFICIENCY OF THE SYSTEM MAY BE AFFECTED. CONSEQUENTLY,
1551: # THESE PARAMETERS MAY REQUIRE TUNING FOR A GIVEN VERSION
1552: # THE VALUES GIVEN IN COMMENTS HAVE BEEN SUCCESSFULLY USED.
1553: #
1554: # E$SRS IS THE NUMBER OF WORDS TO RESERVE AT THE END OF
1555: # STORAGE FOR END OF RUN PROCESSING. IT SHOULD BE
1556: # SET AS SMALL AS POSSIBLE WITHOUT CAUSING MEMORY OVERFLOW
1557: # IN CRITICAL SITUATIONS (E.G. MEMORY OVERFLOW TERMINATION)
1558: # AND SHOULD THUS RESERVE SUFFICIENT SPACE AT LEAST FOR
1559: # AN SCBLK CONTAINING SAY 30 CHARACTERS.
1560: #
1561: .set e$srs,50 # 30 words
1562: #
1563: # E$STS IS THE NUMBER OF WORDS GRABBED IN A CHUNK WHEN
1564: # STORAGE IS ALLOCATED IN THE STATIC REGION. THE MINIMUM
1565: # PERMITTED VALUE IS 256/CFP$B. LARGER VALUES WILL LEAD
1566: # TO INCREASED EFFICIENCY AT THE COST OF WASTING MEMORY.
1567: #
1568: .set e$sts,512 # 500 words
1569: #
1570: # E$CBS IS THE SIZE OF CODE BLOCK ALLOCATED INITIALLY AND
1571: # THE EXPANSION INCREMENT IF OVERFLOW OCCURS. IF THIS VALUE
1572: # IS TOO SMALL OR TOO LARGE, EXCESSIVE GARBAGE COLLECTIONS
1573: # WILL OCCUR DURING COMPILATION AND MEMORY MAY BE LOST
1574: # IN THE CASE OF A TOO LARGE VALUE.
1575: #
1576: .set e$cbs,512 # 500 words
1577: #
1578: # E$HNB IS THE NUMBER OF BUCKET HEADERS IN THE VARIABLE
1579: # HASH TABLE. IT SHOULD ALWAYS BE ODD. LARGER VALUES WILL
1580: # SPEED UP COMPILATION AND INDIRECT REFERENCES AT THE
1581: # EXPENSE OF ADDITIONAL STORAGE FOR THE HASH TABLE ITSELF.
1582: #
1583: .set e$hnb,253 # 127 bucket headers
1584: #
1585: # E$HNW IS THE MAXIMUM NUMBER OF WORDS OF A STRING
1586: # NAME WHICH PARTICIPATE IN THE STRING HASH ALGORITHM.
1587: # LARGER VALUES GIVE A BETTER HASH AT THE EXPENSE OF TAKING
1588: # LONGER TO COMPUTE THE HASH. THERE IS SOME OPTIMAL VALUE.
1589: #
1590: .set e$hnw,3 # 6 words
1591: #
1592: # E$FSP . IF THE AMOUNT OF FREE SPACE LEFT AFTER A GARBAGE
1593: # COLLECTION IS SMALL COMPARED TO THE TOTAL AMOUNT OF SPACE
1594: # IN USE GARBAGE COLLECTOR THRASHING IS LIKELY TO OCCUR AS
1595: # THIS SPACE IS USED UP. E$FSP IS A MEASURE OF THE
1596: # MINIMUM PERCENTAGE OF DYNAMIC MEMORY LEFT AS FREE SPACE
1597: # BEFORE THE SYSTEM ROUTINE SYSMM IS CALLED TO TRY TO
1598: # OBTAIN MORE MEMORY.
1599: #
1600: .set e$fsp,20 # 15 percent
1601: #page
1602: #
1603: # DEFINITIONS OF CODES FOR LETTERS
1604: #
1605: .set ch$la,65 # letter a
1606: .set ch$lb,66 # letter b
1607: .set ch$lc,67 # letter c
1608: .set ch$ld,68 # letter d
1609: .set ch$le,69 # letter e
1610: .set ch$lf,70 # letter f
1611: .set ch$lg,71 # letter g
1612: .set ch$lh,72 # letter h
1613: .set ch$li,73 # letter i
1614: .set ch$lj,74 # letter j
1615: .set ch$lk,75 # letter k
1616: .set ch$ll,76 # letter l
1617: .set ch$lm,77 # letter m
1618: .set ch$ln,78 # letter n
1619: .set ch$lo,79 # letter o
1620: .set ch$lp,80 # letter p
1621: .set ch$lq,81 # letter q
1622: .set ch$lr,82 # letter r
1623: .set ch$ls,83 # letter s
1624: .set ch$lt,84 # letter t
1625: .set ch$lu,85 # letter u
1626: .set ch$lv,86 # letter v
1627: .set ch$lw,87 # letter w
1628: .set ch$lx,88 # letter x
1629: .set ch$ly,89 # letter y
1630: .set ch$l$,90 # letter z
1631: #
1632: # DEFINITIONS OF CODES FOR DIGITS
1633: #
1634: .set ch$d0,48 # digit 0
1635: .set ch$d1,49 # digit 1
1636: .set ch$d2,50 # digit 2
1637: .set ch$d3,51 # digit 3
1638: .set ch$d4,52 # digit 4
1639: .set ch$d5,53 # digit 5
1640: .set ch$d6,54 # digit 6
1641: .set ch$d7,55 # digit 7
1642: .set ch$d8,56 # digit 8
1643: .set ch$d9,57 # digit 9
1644: #page
1645: #
1646: # DEFINITIONS OF CODES FOR SPECIAL CHARACTERS
1647: #
1648: # THE NAMES OF THESE CHARACTERS ARE RELATED TO THEIR
1649: # ORIGINAL REPRESENTATION IN THE EBCDIC SET CORRESPONDING
1650: # TO THE DESCRIPTION IN STANDARD SNOBOL4 MANUALS AND TEXTS.
1651: #
1652: .set ch$am,38 # keyword operator (ampersand)
1653: .set ch$as,42 # multiplication symbol (asterisk)
1654: .set ch$at,64 # cursor position operator (at)
1655: .set ch$bb,60 # left array bracket (less than)
1656: .set ch$bl,32 # blank
1657: .set ch$br,124 # alternation operator (vertical bar)
1658: .set ch$cl,58 # goto symbol (colon)
1659: .set ch$cm,44 # comma
1660: .set ch$dl,36 # indirection operator (dollar)
1661: .set ch$dt,46 # name operator (dot)
1662: .set ch$dq,34 # double quote
1663: .set ch$eq,61 # equal sign
1664: .set ch$ex,33 # exponentiation operator (exclm)
1665: .set ch$mn,45 # minus sign
1666: .set ch$nm,35 # number sign
1667: .set ch$nt,126 # negation operator (not)
1668: .set ch$pc,37 # percent
1669: .set ch$pl,43 # plus sign
1670: .set ch$pp,40 # left parenthesis
1671: .set ch$rb,62 # right array bracket (grtr than)
1672: .set ch$rp,41 # right parenthesis
1673: .set ch$qu,63 # interrogation operator (question)
1674: .set ch$sl,47 # slash
1675: .set ch$sm,59 # semicolon
1676: .set ch$sq,39 # single quote
1677: .set ch$un,95 # special identifier char (underline)
1678: .set ch$ob,91 # opening bracket
1679: .set ch$cb,93 # closing bracket
1680: #page
1681: #
1682: # REMAINING CHARS ARE OPTIONAL ADDITIONS TO THE STANDARDS.
1683: #
1684: # TAB CHARACTERS - SYNTACTICALLY EQUIVALENT TO BLANK
1685: #
1686: .set ch$ht,9 # horizontal tab
1687: #
1688: # LOWER CASE OR SHIFTED CASE ALPHABETIC CHARS
1689: #
1690: .set ch$$a,97 # shifted a
1691: .set ch$$b,98 # shifted b
1692: .set ch$$c,99 # shifted c
1693: .set ch$$d,100 # shifted d
1694: .set ch$$e,101 # shifted e
1695: .set ch$$f,102 # shifted f
1696: .set ch$$g,103 # shifted g
1697: .set ch$$h,104 # shifted h
1698: .set ch$$i,105 # shifted i
1699: .set ch$$j,106 # shifted j
1700: .set ch$$k,107 # shifted k
1701: .set ch$$l,108 # shifted l
1702: .set ch$$m,109 # shifted m
1703: .set ch$$n,110 # shifted n
1704: .set ch$$o,111 # shifted o
1705: .set ch$$p,112 # shifted p
1706: .set ch$$q,113 # shifted q
1707: .set ch$$r,114 # shifted r
1708: .set ch$$s,115 # shifted s
1709: .set ch$$t,116 # shifted t
1710: .set ch$$u,117 # shifted u
1711: .set ch$$v,118 # shifted v
1712: .set ch$$w,119 # shifted w
1713: .set ch$$x,120 # shifted x
1714: .set ch$$y,121 # shifted y
1715: .set ch$$$,122 # shifted z
1716: # IF A DELIMITER OTHER THAN CH$CM MUST BE USED IN
1717: # THE THIRD ARGUMENT OF INPUT(),OUTPUT() THEN .CIOD SHOULD
1718: # BE DEFINED AND A PARAMETER SUPPLIED FOR IODEL.
1719: #
1720: .set iodel,0
1721: #page
1722: #
1723: # DATA BLOCK FORMATS AND DEFINITIONS
1724: #
1725: # THE FOLLOWING SECTIONS DESCRIBE THE DETAILED FORMAT OF
1726: # ALL POSSIBLE DATA BLOCKS IN STATIC AND DYNAMIC MEMORY.
1727: #
1728: # EVERY BLOCK HAS A NAME OF THE FORM XXBLK WHERE XX IS A
1729: # UNIQUE TWO CHARACTER IDENTIFIER. THE FIRST WORD OF EVERY
1730: # BLOCK MUST CONTAIN A POINTER TO A PROGRAM LOCATION IN THE
1731: # INTERPRETOR WHICH IS IMMEDIATELY PRECEDED BY AN ADDRESS
1732: # CONSTANT CONTAINING THE VALUE BL$XX WHERE XX IS THE BLOCK
1733: # IDENTIFIER. THIS PROVIDES A UNIFORM MECHANISM FOR
1734: # DISTINGUISHING BETWEEN THE VARIOUS BLOCK TYPES.
1735: #
1736: # IN SOME CASES, THE CONTENTS OF THE FIRST WORD IS CONSTANT
1737: # FOR A GIVEN BLOCK TYPE AND MERELY SERVES AS A POINTER
1738: # TO THE IDENTIFYING ADDRESS CONSTANT. HOWEVER, IN OTHER
1739: # CASES THERE ARE SEVERAL POSSIBILITIES FOR THE FIRST
1740: # WORD IN WHICH CASE EACH OF THE SEVERAL PROGRAM ENTRY
1741: # POINTS MUST BE PRECEDED BY THE APPROPRIATE CONSTANT.
1742: #
1743: # IN EACH BLOCK, SOME OF THE FIELDS ARE RELOCATABLE. THIS
1744: # MEANS THAT THEY MAY CONTAIN A POINTER TO ANOTHER BLOCK
1745: # IN THE DYNAMIC AREA. (TO BE MORE PRECISE, IF THEY CONTAIN
1746: # A POINTER WITHIN THE DYNAMIC AREA, THEN IT IS A POINTER
1747: # TO A BLOCK). SUCH FIELDS MUST BE MODIFIED BY THE GARBAGE
1748: # COLLECTOR (PROCEDURE GBCOL) WHENEVER BLOCKS ARE COMPACTED
1749: # IN THE DYNAMIC REGION. THE GARBAGE COLLECTOR (ACTUALLY
1750: # PROCEDURE GBCPF) REQUIRES THAT ALL SUCH RELOCATABLE
1751: # FIELDS IN A BLOCK MUST BE CONTIGUOUS.
1752: #page
1753: #
1754: # THE DESCRIPTION FORMAT USES THE FOLLOWING SCHEME.
1755: #
1756: # 1) BLOCK TITLE AND TWO CHARACTER IDENTIFIER
1757: #
1758: # 2) DESCRIPTION OF BASIC USE OF BLOCK AND INDICATION
1759: # OF CIRCUMSTANCES UNDER WHICH IT IS CONSTRUCTED.
1760: #
1761: # 3) PICTURE OF THE BLOCK FORMAT. IN THESE PICTURES LOW
1762: # MEMORY ADDRESSES ARE AT THE TOP OF THE PAGE. FIXED
1763: # LENGTH FIELDS ARE SURROUNDED BY I (LETTER I). FIELDS
1764: # WHICH ARE FIXED LENGTH BUT WHOSE LENGTH IS DEPENDENT
1765: # ON A CONFIGURATION PARAMETER ARE SURROUNDED BY *
1766: # (ASTERISK). VARIABLE LENGTH FIELDS ARE SURROUNDED
1767: # BY / (SLASH).
1768: #
1769: # 4) DEFINITION OF SYMBOLIC OFFSETS TO FIELDS IN
1770: # BLOCK AND OF THE SIZE OF THE BLOCK IF FIXED LENGTH
1771: # OR OF THE SIZE OF THE FIXED LENGTH FIELDS IF THE
1772: # BLOCK IS VARIABLE LENGTH.
1773: # NOTE THAT SOME ROUTINES SUCH AS GBCPF ASSUME
1774: # CERTAIN OFFSETS ARE EQUAL. THE DEFINITIONS
1775: # GIVEN HERE ENFORCE THIS. MAKE CHANGES TO
1776: # THEM ONLY WITH DUE CARE.
1777: #
1778: # DEFINITIONS OF COMMON OFFSETS
1779: #
1780: .set offs1,1
1781: .set offs2,2
1782: .set offs3,3
1783: #
1784: # 5) DETAILED COMMENTS ON THE SIGNIFICANCE AND FORMATS
1785: # OF THE VARIOUS FIELDS.
1786: #
1787: # THE ORDER IS ALPHABETICAL BY IDENTIFICATION CODE.
1788: #page
1789: #
1790: # DEFINITIONS OF BLOCK CODES
1791: #
1792: # THIS TABLE PROVIDES A UNIQUE IDENTIFICATION CODE FOR
1793: # EACH SEPARATE BLOCK TYPE. THE FIRST WORD OF A BLOCK IN
1794: # THE DYNAMIC AREA ALWAYS CONTAINS THE ADDRESS OF A PROGRAM
1795: # ENTRY POINT. THE BLOCK CODE IS USED AS THE ENTRY POINT ID
1796: # THE ORDER OF THESE CODES DICTATES THE ORDER OF THE TABLE
1797: # USED BY THE DATATYPE FUNCTION (SCNMT IN THE CONSTANT SEC)
1798: #
1799: # BLOCK CODES FOR ACCESSIBLE DATATYPES
1800: #
1801: .set bl$ar,0 # arblk array
1802: .set bl$bc,bl$ar+1 # bcblk buffer
1803: .set bl$cd,bl$bc+1 # cdblk code
1804: .set bl$ex,bl$cd+1 # exblk expression
1805: .set bl$ic,bl$ex+1 # icblk integer
1806: .set bl$nm,bl$ic+1 # nmblk name
1807: .set bl$p0,bl$nm+1 # p0blk pattern
1808: .set bl$p1,bl$p0+1 # p1blk pattern
1809: .set bl$p2,bl$p1+1 # p2blk pattern
1810: .set bl$rc,bl$p2+1 # rcblk real
1811: .set bl$sc,bl$rc+1 # scblk string
1812: .set bl$se,bl$sc+1 # seblk expression
1813: .set bl$tb,bl$se+1 # tbblk table
1814: .set bl$vc,bl$tb+1 # vcblk array
1815: .set bl$xn,bl$vc+1 # xnblk external
1816: .set bl$xr,bl$xn+1 # xrblk external
1817: .set bl$pd,bl$xr+1 # pdblk program defined datatype
1818: #
1819: .set bl$$d,bl$pd+1 # number of block codes for data
1820: #
1821: # OTHER BLOCK CODES
1822: #
1823: .set bl$tr,bl$pd+1 # trblk
1824: .set bl$bf,bl$tr+1 # bfblk
1825: .set bl$cc,bl$bf+1 # ccblk
1826: .set bl$cm,bl$cc+1 # cmblk
1827: .set bl$ct,bl$cm+1 # ctblk
1828: .set bl$df,bl$ct+1 # dfblk
1829: .set bl$ef,bl$df+1 # efblk
1830: .set bl$ev,bl$ef+1 # evblk
1831: .set bl$ff,bl$ev+1 # ffblk
1832: .set bl$kv,bl$ff+1 # kvblk
1833: .set bl$pf,bl$kv+1 # pfblk
1834: .set bl$te,bl$pf+1 # teblk
1835: #
1836: .set bl$$i,0 # default identification code
1837: .set bl$$t,bl$tr+1 # code for data or trace block
1838: .set bl$$$,bl$te+1 # number of block codes
1839: #page
1840: #
1841: # FIELD REFERENCES
1842: #
1843: # REFERENCES TO THE FIELDS OF DATA BLOCKS ARE SYMBOLIC
1844: # (I.E. USE THE SYMBOLIC OFFSETS) WITH THE FOLLOWING
1845: # EXCEPTIONS.
1846: #
1847: # 1) REFERENCES TO THE FIRST WORD ARE USUALLY NOT
1848: # SYMBOLIC SINCE THEY USE THE (X) OPERAND FORMAT.
1849: #
1850: # 2) THE CODE WHICH CONSTRUCTS A BLOCK IS OFTEN NOT
1851: # SYMBOLIC AND SHOULD BE CHANGED IF THE CORRESPONDING
1852: # BLOCK FORMAT IS MODIFIED.
1853: #
1854: # 3) THE PLC AND PSC INSTRUCTIONS IMPLY AN OFFSET
1855: # CORRESPONDING TO THE DEFINITION OF CFP$F.
1856: #
1857: # 4) THERE ARE NON-SYMBOLIC REFERENCES (EASILY CHANGED)
1858: # IN THE GARBAGE COLLECTOR (PROCEDURES GBCPF, BLKLN).
1859: #
1860: # 5) THE FIELDS IDVAL, FARGS APPEAR IN SEVERAL BLOCKS
1861: # AND ANY CHANGES MUST BE MADE IN PARALLEL TO ALL
1862: # BLOCKS CONTAINING THE FIELDS. THE ACTUAL REFERENCES
1863: # TO THESE FIELDS ARE SYMBOLIC WITH THE ABOVE
1864: # LISTED EXCEPTIONS.
1865: #
1866: # 6) SEVERAL SPOTS IN THE CODE ASSUME THAT THE
1867: # DEFINITIONS OF THE FIELDS VRVAL, TEVAL, TRNXT ARE
1868: # THE SAME (THESE ARE SECTIONS OF CODE WHICH SEARCH
1869: # OUT ALONG A TRBLK CHAIN FROM A VARIABLE).
1870: #
1871: # 7) REFERENCES TO THE FIELDS OF AN ARRAY BLOCK IN THE
1872: # ARRAY REFERENCE ROUTINE ARREF ARE NON-SYMBOLIC.
1873: #
1874: # APART FROM THE EXCEPTIONS LISTED, REFERENCES ARE SYMBOLIC
1875: # AS FAR AS POSSIBLE AND MODIFYING THE ORDER OR NUMBER
1876: # OF FIELDS WILL NOT REQUIRE CHANGES.
1877: #page
1878: #
1879: # COMMON FIELDS FOR FUNCTION BLOCKS
1880: #
1881: # BLOCKS WHICH REPRESENT CALLABLE FUNCTIONS HAVE TWO
1882: # COMMON FIELDS AT THE START OF THE BLOCK AS FOLLOWS.
1883: #
1884: # +------------------------------------+
1885: # I FCODE I
1886: # +------------------------------------+
1887: # I FARGS I
1888: # +------------------------------------+
1889: # / /
1890: # / REST OF FUNCTION BLOCK /
1891: # / /
1892: # +------------------------------------+
1893: #
1894: .set fcode,0 # pointer to code for function
1895: .set fargs,1 # number of arguments
1896: #
1897: # FCODE IS A POINTER TO THE LOCATION IN THE INTERPRETOR
1898: # PROGRAM WHICH PROCESSES THIS TYPE OF FUNCTION CALL.
1899: #
1900: # FARGS IS THE EXPECTED NUMBER OF ARGUMENTS. THE ACTUAL
1901: # NUMBER OF ARGUMENTS IS ADJUSTED TO THIS AMOUNT BY
1902: # DELETING EXTRA ARGUMENTS OR SUPPLYING TRAILING NULLS
1903: # FOR MISSING ONES BEFORE TRANSFERRING THOUGH FCODE.
1904: # A VALUE OF 999 MAY BE USED IN THIS FIELD TO INDICATE A
1905: # VARIABLE NUMBER OF ARGUMENTS (SEE SVBLK FIELD SVNAR).
1906: #
1907: # THE BLOCK TYPES WHICH FOLLOW THIS SCHEME ARE.
1908: #
1909: # FFBLK FIELD FUNCTION
1910: # DFBLK DATATYPE FUNCTION
1911: # PFBLK PROGRAM DEFINED FUNCTION
1912: # EFBLK EXTERNAL LOADED FUNCTION
1913: #page
1914: #
1915: # IDENTIFICATION FIELD
1916: #
1917: #
1918: # ID FIELD
1919: #
1920: # CERTAIN PROGRAM ACCESSIBLE OBJECTS (THOSE WHICH CONTAIN
1921: # OTHER DATA VALUES AND CAN BE COPIED) ARE GIVEN A UNIQUE
1922: # IDENTIFICATION NUMBER (SEE EXSID). THIS ID VALUE IS AN
1923: # ADDRESS INTEGER VALUE WHICH IS ALWAYS STORED IN WORD TWO.
1924: #
1925: .set idval,1 # id value field
1926: #
1927: # THE BLOCKS CONTAINING AN IDVAL FIELD ARE.
1928: #
1929: # ARBLK ARRAY
1930: # BCBLK BUFFER CONTROL BLOCK
1931: # PDBLK PROGRAM DEFINED DATATYPE
1932: # TBBLK TABLE
1933: # VCBLK VECTOR BLOCK (ARRAY)
1934: #
1935: # NOTE THAT A ZERO IDVAL MEANS THAT THE BLOCK IS ONLY
1936: # HALF BUILT AND SHOULD NOT BE DUMPED (SEE DUMPR).
1937: #page
1938: #
1939: # ARRAY BLOCK (ARBLK)
1940: #
1941: # AN ARRAY BLOCK REPRESENTS AN ARRAY VALUE OTHER THAN ONE
1942: # WITH ONE DIMENSION WHOSE LOWER BOUND IS ONE (SEE VCBLK).
1943: # AN ARBLK IS BUILT WITH A CALL TO THE FUNCTIONS CONVERT
1944: # (S$CNV) OR ARRAY (S$ARR).
1945: #
1946: # +------------------------------------+
1947: # I ARTYP I
1948: # +------------------------------------+
1949: # I IDVAL I
1950: # +------------------------------------+
1951: # I ARLEN I
1952: # +------------------------------------+
1953: # I AROFS I
1954: # +------------------------------------+
1955: # I ARNDM I
1956: # +------------------------------------+
1957: # * ARLBD *
1958: # +------------------------------------+
1959: # * ARDIM *
1960: # +------------------------------------+
1961: # * *
1962: # * ABOVE 2 FLDS REPEATED FOR EACH DIM *
1963: # * *
1964: # +------------------------------------+
1965: # I ARPRO I
1966: # +------------------------------------+
1967: # / /
1968: # / ARVLS /
1969: # / /
1970: # +------------------------------------+
1971: #page
1972: #
1973: # ARRAY BLOCK (CONTINUED)
1974: #
1975: .set artyp,0 # pointer to dummy routine b$art
1976: .set arlen,idval+1 # length of arblk in bytes
1977: .set arofs,arlen+1 # offset in arblk to arpro field
1978: .set arndm,arofs+1 # number of dimensions
1979: .set arlbd,arndm+1 # low bound (first subscript)
1980: .set ardim,arlbd+cfp$i# dimension (first subscript)
1981: .set arlb2,ardim+cfp$i# low bound (second subscript)
1982: .set ardm2,arlb2+cfp$i# dimension (second subscript)
1983: .set arpro,ardim+cfp$i# array prototype (one dimension)
1984: .set arvls,arpro+1 # start of values (one dimension)
1985: .set arpr2,ardm2+cfp$i# array prototype (two dimensions)
1986: .set arvl2,arpr2+1 # start of values (two dimensions)
1987: .set arsi$,arlbd # number of standard fields in block
1988: .set ardms,arlb2-arlbd# size of info for one set of bounds
1989: #
1990: # THE BOUNDS AND DIMENSION FIELDS ARE SIGNED INTEGER
1991: # VALUES AND EACH OCCUPY CFP$I WORDS IN THE ARBLK.
1992: #
1993: # THE LENGTH OF AN ARBLK IN BYTES MAY NOT EXCEED MXLEN.
1994: # THIS IS REQUIRED TO KEEP NAME OFFSETS GARBAGE COLLECTABLE
1995: #
1996: # THE ACTUAL VALUES ARE ARRANGED IN ROW-WISE ORDER AND
1997: # CAN CONTAIN A DATA POINTER OR A POINTER TO A TRBLK.
1998: #
1999: # BUFFER CONTROL BLOCK (BCBLK)
2000: #
2001: # A BCBLK IS BUILT FOR EVERY BFBLK.
2002: #
2003: # +------------------------------------+
2004: # I BCTYP I
2005: # +------------------------------------+
2006: # I IDVAL I
2007: # +------------------------------------+
2008: # I BCLEN I
2009: # +------------------------------------+
2010: # I BCBUF I
2011: # +------------------------------------+
2012: #
2013: .set bctyp,0 # ptr to dummy routine b$bct
2014: .set bclen,idval+1 # defined buffer length
2015: .set bcbuf,bclen+1 # ptr to bfblk
2016: .set bcsi$,bcbuf+1 # size of bcblk
2017: #
2018: # A BCBLK IS AN INDIRECT CONTROL HEADER FOR BFBLK.
2019: # THE REASON FOR NOT STORING THIS DATA DIRECTLY
2020: # IN THE RELATED BFBLK IS SO THAT THE BFBLK CAN
2021: # MAINTAIN THE SAME SKELETAL STRUCTURE AS AN SCBLK
2022: # THUS FACILITATING TRANSPARENT STRING OPERATIONS
2023: # (FOR THE MOST PART). SPECIFICALLY, CFP$F IS THE
2024: # SAME FOR A BFBLK AS FOR AN SCBLK. BY CONVENTION,
2025: # WHEREEVER A BUFFER VALUE IS EMPLOYED, THE BCBLK
2026: # IS POINTED TO.
2027: #
2028: # THE CORRESPONDING BFBLK IS POINTED TO BY THE
2029: # BCBUF POINTER IN THE BCBLK.
2030: #
2031: # BCLEN IS THE CURRENT DEFINED SIZE OF THE CHARACTER
2032: # ARRAY IN THE BFBLK. CHARACTERS FOLLOWING THE OFFSET
2033: # OF BCLEN ARE UNDEFINED.
2034: #
2035: #page
2036: #
2037: # STRING BUFFER BLOCK (BFBLK)
2038: #
2039: # A BFBLK IS BUILT BY A CALL TO BUFFER(...)
2040: #
2041: # +------------------------------------+
2042: # I BFTYP I
2043: # +------------------------------------+
2044: # I BFALC I
2045: # +------------------------------------+
2046: # / /
2047: # / BFCHR /
2048: # / /
2049: # +------------------------------------+
2050: #
2051: .set bftyp,0 # ptr to dummy routine b$bft
2052: .set bfalc,bftyp+1 # allocated size of buffer
2053: .set bfchr,bfalc+1 # characters of string
2054: .set bfsi$,bfchr # size of standard fields in bfblk
2055: #
2056: # THE CHARACTERS IN THE BUFFER ARE STORED LEFT JUSTIFIED.
2057: # THE FINAL WORD OF DEFINED CHARACTERS IS ALWAYS ZERO
2058: # (CHARACTER) PADDED. ANY TRAILING ALLOCATION PAST THE
2059: # WORD CONTAINING THE LAST CHARACTER CONTAINS
2060: # UNPREDICTABLE CONTENTS AND IS NEVER REFERENCED.
2061: #
2062: # NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING
2063: # IS GIVEN BY CFP$F, AS WITH AN SCBLK. HOWEVER, THE
2064: # OFFSET WHICH IS OCCUPIED BY THE LENGTH FOR AN SCBLK
2065: # IS THE TOTAL CHAR SPACE FOR BFBLKS, AND ROUTINES WHICH
2066: # DEAL WITH BOTH MUST ACCOUNT FOR THIS DIFFERENCE.
2067: #
2068: # THE VALUE OF BFALC MAY NOT EXCEED MXLEN. THE VALUE OF
2069: # BCLEN IS ALWAYS LESS THAN OR EQUAL TO BFALC.
2070: #
2071: #page
2072: #
2073: # CODE CONSTRUCTION BLOCK (CCBLK)
2074: #
2075: # AT ANY ONE MOMENT THERE IS AT MOST ONE CCBLK INTO
2076: # WHICH THE COMPILER IS CURRENTLY STORING CODE (CDWRD).
2077: #
2078: # +------------------------------------+
2079: # I CCTYP I
2080: # +------------------------------------+
2081: # I CCLEN I
2082: # +------------------------------------+
2083: # I CCUSE I
2084: # +------------------------------------+
2085: # / /
2086: # / CCCOD /
2087: # / /
2088: # +------------------------------------+
2089: #
2090: .set cctyp,0 # pointer to dummy routine b$cct
2091: .set cclen,cctyp+1 # length of ccblk in bytes
2092: .set ccuse,cclen+1 # offset past last used word (bytes)
2093: .set cccod,ccuse+1 # start of generated code in block
2094: #
2095: # THE REASON THAT THE CCBLK IS A SEPARATE BLOCK TYPE FROM
2096: # THE USUAL CDBLK IS THAT THE GARBAGE COLLECTOR MUST
2097: # ONLY PROCESS THOSE FIELDS WHICH HAVE BEEN SET (SEE GBCPF)
2098: #page
2099: #
2100: # CODE BLOCK (CDBLK)
2101: #
2102: # A CODE BLOCK IS BUILT FOR EACH STATEMENT COMPILED DURING
2103: # THE INITIAL COMPILATION OR BY SUBSEQUENT CALLS TO CODE.
2104: #
2105: # +------------------------------------+
2106: # I CDJMP I
2107: # +------------------------------------+
2108: # I CDSTM I
2109: # +------------------------------------+
2110: # I CDLEN I
2111: # +------------------------------------+
2112: # I CDFAL I
2113: # +------------------------------------+
2114: # / /
2115: # / CDCOD /
2116: # / /
2117: # +------------------------------------+
2118: #
2119: .set cdjmp,0 # ptr to routine to execute statement
2120: .set cdstm,cdjmp+1 # statement number
2121: .set cdlen,offs2 # length of cdblk in bytes
2122: .set cdfal,offs3 # failure exit (see below)
2123: .set cdcod,cdfal+1 # executable pseudo-code
2124: .set cdsi$,cdcod # number of standard fields in cdblk
2125: #
2126: # CDSTM IS THE STATEMENT NUMBER OF THE CURRENT STATEMENT.
2127: #
2128: # CDJMP, CDFAL ARE SET AS FOLLOWS.
2129: #
2130: # 1) IF THE FAILURE EXIT IS THE NEXT STATEMENT
2131: #
2132: # CDJMP = B$CDS
2133: # CDFAL = PTR TO CDBLK FOR NEXT STATEMENT
2134: #
2135: # 2) IF THE FAILURE EXIT IS A SIMPLE LABEL NAME
2136: #
2137: # CDJMP = B$CDS
2138: # CDFAL IS A PTR TO THE VRTRA FIELD OF THE VRBLK
2139: #
2140: # 3) IF THERE IS NO FAILURE EXIT (-NOFAIL MODE)
2141: #
2142: # CDJMP = B$CDS
2143: # CDFAL = O$UNF
2144: #
2145: # 4) IF THE FAILURE EXIT IS COMPLEX OR DIRECT
2146: #
2147: # CDJMP = B$CDC
2148: # CDFAL IS THE OFFSET TO THE O$GOF WORD
2149: #page
2150: #
2151: # CODE BLOCK (CONTINUED)
2152: #
2153: # CDCOD IS THE START OF THE ACTUAL CODE. FIRST WE DESCRIBE
2154: # THE CODE GENERATED FOR AN EXPRESSION. IN AN EXPRESSION,
2155: # ELEMENTS ARE FETCHED BY NAME OR BY VALUE. FOR EXAMPLE,
2156: # THE BINARY EQUAL OPERATOR FETCHES ITS LEFT ARGUMENT
2157: # BY NAME AND ITS RIGHT ARGUMENT BY VALUE. THESE TWO
2158: # CASES GENERATE QUITE DIFFERENT CODE AND ARE DESCRIBED
2159: # SEPARATELY. FIRST WE CONSIDER THE CODE BY VALUE CASE.
2160: #
2161: # GENERATION OF CODE BY VALUE FOR EXPRESSIONS ELEMENTS.
2162: #
2163: # EXPRESSION POINTER TO EXBLK OR SEBLK
2164: #
2165: # INTEGER CONSTANT POINTER TO ICBLK
2166: #
2167: # NULL CONSTANT POINTER TO NULLS
2168: #
2169: # PATTERN (RESULTING FROM PREEVALUATION)
2170: # =O$LPT
2171: # POINTER TO P0BLK,P1BLK OR P2BLK
2172: #
2173: # REAL CONSTANT POINTER TO RCBLK
2174: #
2175: # STRING CONSTANT POINTER TO SCBLK
2176: #
2177: # VARIABLE POINTER TO VRGET FIELD OF VRBLK
2178: #
2179: # ADDITION VALUE CODE FOR LEFT OPERAND
2180: # VALUE CODE FOR RIGHT OPERAND
2181: # =O$ADD
2182: #
2183: # AFFIRMATION VALUE CODE FOR OPERAND
2184: # =O$AFF
2185: #
2186: # ALTERNATION VALUE CODE FOR LEFT OPERAND
2187: # VALUE CODE FOR RIGHT OPERAND
2188: # =O$ALT
2189: #
2190: # ARRAY REFERENCE (CASE OF ONE SUBSCRIPT)
2191: # VALUE CODE FOR ARRAY OPERAND
2192: # VALUE CODE FOR SUBSCRIPT OPERAND
2193: # =O$AOV
2194: #
2195: # (CASE OF MORE THAN ONE SUBSCRIPT)
2196: # VALUE CODE FOR ARRAY OPERAND
2197: # VALUE CODE FOR FIRST SUBSCRIPT
2198: # VALUE CODE FOR SECOND SUBSCRIPT
2199: # ...
2200: # VALUE CODE FOR LAST SUBSCRIPT
2201: # =O$AMV
2202: # NUMBER OF SUBSCRIPTS
2203: #page
2204: #
2205: # CODE BLOCK (CONTINUED)
2206: #
2207: # ASSIGNMENT (TO NATURAL VARIABLE)
2208: # VALUE CODE FOR RIGHT OPERAND
2209: # POINTER TO VRSTO FIELD OF VRBLK
2210: #
2211: # (TO ANY OTHER VARIABLE)
2212: # NAME CODE FOR LEFT OPERAND
2213: # VALUE CODE FOR RIGHT OPERAND
2214: # =O$ASS
2215: #
2216: # COMPILE ERROR =O$CER
2217: #
2218: #
2219: # COMPLEMENTATION VALUE CODE FOR OPERAND
2220: # =O$COM
2221: #
2222: # CONCATENATION (CASE OF PRED FUNC LEFT OPERAND)
2223: # VALUE CODE FOR LEFT OPERAND
2224: # =O$POP
2225: # VALUE CODE FOR RIGHT OPERAND
2226: #
2227: # (ALL OTHER CASES)
2228: # VALUE CODE FOR LEFT OPERAND
2229: # VALUE CODE FOR RIGHT OPERAND
2230: # =O$CNC
2231: #
2232: # CURSOR ASSIGNMENT NAME CODE FOR OPERAND
2233: # =O$CAS
2234: #
2235: # DIVISION VALUE CODE FOR LEFT OPERAND
2236: # VALUE CODE FOR RIGHT OPERAND
2237: # =O$DVD
2238: #
2239: # EXPONENTIATION VALUE CODE FOR LEFT OPERAND
2240: # VALUE CODE FOR RIGHT OPERAND
2241: # =O$EXP
2242: #
2243: # FUNCTION CALL (CASE OF CALL TO SYSTEM FUNCTION)
2244: # VALUE CODE FOR FIRST ARGUMENT
2245: # VALUE CODE FOR SECOND ARGUMENT
2246: # ...
2247: # VALUE CODE FOR LAST ARGUMENT
2248: # POINTER TO SVFNC FIELD OF SVBLK
2249: #
2250: #page
2251: #
2252: # CODE BLOCK (CONTINUED)
2253: #
2254: # FUNCTION CALL (CASE OF NON-SYSTEM FUNCTION 1 ARG)
2255: # VALUE CODE FOR ARGUMENT
2256: # =O$FNS
2257: # POINTER TO VRBLK FOR FUNCTION
2258: #
2259: # (NON-SYSTEM FUNCTION, GT 1 ARG)
2260: # VALUE CODE FOR FIRST ARGUMENT
2261: # VALUE CODE FOR SECOND ARGUMENT
2262: # ...
2263: # VALUE CODE FOR LAST ARGUMENT
2264: # =O$FNC
2265: # NUMBER OF ARGUMENTS
2266: # POINTER TO VRBLK FOR FUNCTION
2267: #
2268: # IMMEDIATE ASSIGNMENT VALUE CODE FOR LEFT OPERAND
2269: # NAME CODE FOR RIGHT OPERAND
2270: # =O$IMA
2271: #
2272: # INDIRECTION VALUE CODE FOR OPERAND
2273: # =O$INV
2274: #
2275: # INTERROGATION VALUE CODE FOR OPERAND
2276: # =O$INT
2277: #
2278: # KEYWORD REFERENCE NAME CODE FOR OPERAND
2279: # =O$KWV
2280: #
2281: # MULTIPLICATION VALUE CODE FOR LEFT OPERAND
2282: # VALUE CODE FOR RIGHT OPERAND
2283: # =O$MLT
2284: #
2285: # NAME REFERENCE (NATURAL VARIABLE CASE)
2286: # POINTER TO NMBLK FOR NAME
2287: #
2288: # (ALL OTHER CASES)
2289: # NAME CODE FOR OPERAND
2290: # =O$NAM
2291: #
2292: # NEGATION =O$NTA
2293: # CDBLK OFFSET OF O$NTC WORD
2294: # VALUE CODE FOR OPERAND
2295: # =O$NTB
2296: # =O$NTC
2297: #page
2298: #
2299: # CODE BLOCK (CONTINUED)
2300: #
2301: # PATTERN ASSIGNMENT VALUE CODE FOR LEFT OPERAND
2302: # NAME CODE FOR RIGHT OPERAND
2303: # =O$PAS
2304: #
2305: # PATTERN MATCH VALUE CODE FOR LEFT OPERAND
2306: # VALUE CODE FOR RIGHT OPERAND
2307: # =O$PMV
2308: #
2309: # PATTERN REPLACEMENT NAME CODE FOR SUBJECT
2310: # VALUE CODE FOR PATTERN
2311: # =O$PMN
2312: # VALUE CODE FOR REPLACEMENT
2313: # =O$RPL
2314: #
2315: # SELECTION (FOR FIRST ALTERNATIVE)
2316: # =O$SLA
2317: # CDBLK OFFSET TO NEXT O$SLC WORD
2318: # VALUE CODE FOR FIRST ALTERNATIVE
2319: # =O$SLB
2320: # CDBLK OFFSET PAST ALTERNATIVES
2321: #
2322: # (FOR SUBSEQUENT ALTERNATIVES)
2323: # =O$SLC
2324: # CDBLK OFFSET TO NEXT O$SLC,O$SLD
2325: # VALUE CODE FOR ALTERNATIVE
2326: # =O$SLB
2327: # OFFSET IN CDBLK PAST ALTERNATIVES
2328: #
2329: # (FOR LAST ALTERNATIVE)
2330: # =O$SLD
2331: # VALUE CODE FOR LAST ALTERNATIVE
2332: #
2333: # SUBTRACTION VALUE CODE FOR LEFT OPERAND
2334: # VALUE CODE FOR RIGHT OPERAND
2335: # =O$SUB
2336: #page
2337: #
2338: # CODE BLOCK (CONTINUED)
2339: #
2340: # GENERATION OF CODE BY NAME FOR EXPRESSION ELEMENTS.
2341: #
2342: # VARIABLE =O$LVN
2343: # POINTER TO VRBLK
2344: #
2345: # EXPRESSION (CASE OF *NATURAL VARIABLE)
2346: # =O$LVN
2347: # POINTER TO VRBLK
2348: #
2349: # (ALL OTHER CASES)
2350: # =O$LEX
2351: # POINTER TO EXBLK
2352: #
2353: #
2354: # ARRAY REFERENCE (CASE OF ONE SUBSCRIPT)
2355: # VALUE CODE FOR ARRAY OPERAND
2356: # VALUE CODE FOR SUBSCRIPT OPERAND
2357: # =O$AON
2358: #
2359: # (CASE OF MORE THAN ONE SUBSCRIPT)
2360: # VALUE CODE FOR ARRAY OPERAND
2361: # VALUE CODE FOR FIRST SUBSCRIPT
2362: # VALUE CODE FOR SECOND SUBSCRIPT
2363: # ...
2364: # VALUE CODE FOR LAST SUBSCRIPT
2365: # =O$AMN
2366: # NUMBER OF SUBSCRIPTS
2367: #
2368: # COMPILE ERROR =O$CER
2369: #
2370: # FUNCTION CALL (SAME CODE AS FOR VALUE CALL)
2371: # =O$FNE
2372: #
2373: # INDIRECTION VALUE CODE FOR OPERAND
2374: # =O$INN
2375: #
2376: # KEYWORD REFERENCE NAME CODE FOR OPERAND
2377: # =O$KWN
2378: #
2379: # ANY OTHER OPERAND IS AN ERROR IN A NAME POSITION
2380: #
2381: # NOTE THAT IN THIS DESCRIPTION, =O$XXX REFERS TO THE
2382: # GENERATION OF A WORD CONTAINING THE ADDRESS OF ANOTHER
2383: # WORD WHICH CONTAINS THE ENTRY POINT ADDRESS O$XXX.
2384: #page
2385: #
2386: # CODE BLOCK (CONTINUED)
2387: #
2388: # NOW WE CONSIDER THE OVERALL STRUCTURE OF THE CODE BLOCK
2389: # FOR A STATEMENT WITH POSSIBLE GOTO FIELDS.
2390: #
2391: # FIRST COMES THE CODE FOR THE STATEMENT BODY.
2392: # THE STATEMENT BODY IS AN EXPRESSION TO BE EVALUATED
2393: # BY VALUE ALTHOUGH THE VALUE IS NOT ACTUALLY REQUIRED.
2394: # NORMAL VALUE CODE IS GENERATED FOR THE BODY OF THE
2395: # STATEMENT EXCEPT IN THE CASE OF A PATTERN MATCH BY
2396: # VALUE, IN WHICH CASE THE FOLLOWING IS GENERATED.
2397: #
2398: # VALUE CODE FOR LEFT OPERAND
2399: # VALUE CODE FOR RIGHT OPERAND
2400: # =O$PMS
2401: #
2402: # NEXT WE HAVE THE CODE FOR THE SUCCESS GOTO. THERE ARE
2403: # SEVERAL CASES AS FOLLOWS.
2404: #
2405: # 1) NO SUCCESS GOTO PTR TO CDBLK FOR NEXT STATEMENT
2406: #
2407: # 2) SIMPLE LABEL PTR TO VRTRA FIELD OF VRBLK
2408: #
2409: # 3) COMPLEX GOTO (CODE BY NAME FOR GOTO OPERAND)
2410: # =O$GOC
2411: #
2412: # 4) DIRECT GOTO (CODE BY VALUE FOR GOTO OPERAND)
2413: # =O$GOD
2414: #
2415: # FOLLOWING THIS WE GENERATE CODE FOR THE FAILURE GOTO IF
2416: # IT IS DIRECT OR IF IT IS COMPLEX, SIMPLE FAILURE GOTOS
2417: # HAVING BEEN HANDLED BY AN APPROPRIATE SETTING OF THE
2418: # CDFAL FIELD OF THE CDBLK. THE GENERATED CODE IS ONE
2419: # OF THE FOLLOWING.
2420: #
2421: # 1) COMPLEX FGOTO =O$FIF
2422: # =O$GOF
2423: # NAME CODE FOR GOTO OPERAND
2424: # =O$GOC
2425: #
2426: # 2) DIRECT FGOTO =O$FIF
2427: # =O$GOF
2428: # VALUE CODE FOR GOTO OPERAND
2429: # =O$GOD
2430: #
2431: # AN OPTIMIZATION OCCURS IF THE SUCCESS AND FAILURE GOTOS
2432: # ARE IDENTICAL AND EITHER COMPLEX OR DIRECT. IN THIS CASE,
2433: # NO CODE IS GENERATED FOR THE SUCCESS GOTO AND CONTROL
2434: # IS ALLOWED TO FALL INTO THE FAILURE GOTO ON SUCCESS.
2435: #page
2436: #
2437: # COMPILER BLOCK (CMBLK)
2438: #
2439: # A COMPILER BLOCK (CMBLK) IS BUILT BY EXPAN TO REPRESENT
2440: # ONE NODE OF A TREE STRUCTURED EXPRESSION REPRESENTATION.
2441: #
2442: # +------------------------------------+
2443: # I CMIDN I
2444: # +------------------------------------+
2445: # I CMLEN I
2446: # +------------------------------------+
2447: # I CMTYP I
2448: # +------------------------------------+
2449: # I CMOPN I
2450: # +------------------------------------+
2451: # / CMVLS OR CMROP /
2452: # / /
2453: # / CMLOP /
2454: # / /
2455: # +------------------------------------+
2456: #
2457: .set cmidn,0 # pointer to dummy routine b$cmt
2458: .set cmlen,cmidn+1 # length of cmblk in bytes
2459: .set cmtyp,cmlen+1 # type (c$xxx, see list below)
2460: .set cmopn,cmtyp+1 # operand pointer (see below)
2461: .set cmvls,cmopn+1 # operand value pointers (see below)
2462: .set cmrop,cmvls # right (only) operator operand
2463: .set cmlop,cmvls+1 # left operator operand
2464: .set cmsi$,cmvls # number of standard fields in cmblk
2465: .set cmus$,cmsi$+1 # size of unary operator cmblk
2466: .set cmbs$,cmsi$+2 # size of binary operator cmblk
2467: .set cmar1,cmvls+1 # array subscript pointers
2468: #
2469: # THE CMOPN AND CMVLS FIELDS ARE SET AS FOLLOWS
2470: #
2471: # ARRAY REFERENCE CMOPN = PTR TO ARRAY OPERAND
2472: # CMVLS = PTRS TO SUBSCRIPT OPERANDS
2473: #
2474: # FUNCTION CALL CMOPN = PTR TO VRBLK FOR FUNCTION
2475: # CMVLS = PTRS TO ARGUMENT OPERANDS
2476: #
2477: # SELECTION CMOPN = ZERO
2478: # CMVLS = PTRS TO ALTERNATE OPERANDS
2479: #
2480: # UNARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK
2481: # CMROP = PTR TO OPERAND
2482: #
2483: # BINARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK
2484: # CMROP = PTR TO RIGHT OPERAND
2485: # CMLOP = PTR TO LEFT OPERAND
2486: #page
2487: #
2488: # CMTYP IS SET TO INDICATE THE TYPE OF EXPRESSION ELEMENT
2489: # AS SHOWN BY THE FOLLOWING TABLE OF DEFINITIONS.
2490: #
2491: .set c$arr,0 # array reference
2492: .set c$fnc,c$arr+1 # function call
2493: .set c$def,c$fnc+1 # deferred expression (unary *)
2494: .set c$ind,c$def+1 # indirection (unary $)
2495: .set c$key,c$ind+1 # keyword reference (unary ampersand)
2496: .set c$ubo,c$key+1 # undefined binary operator
2497: .set c$uuo,c$ubo+1 # undefined unary operator
2498: .set c$uo$,c$uuo+1 # test value (=c$uuo+1=c$ubo+2)
2499: .set c$$nm,c$uuo+1 # number of codes for name operands
2500: #
2501: # THE REMAINING TYPES INDICATE EXPRESSION ELEMENTS WHICH
2502: # CAN ONLY BE EVALUATED BY VALUE (NOT BY NAME).
2503: #
2504: .set c$bvl,c$uuo+1 # binary op with value operands
2505: .set c$uvl,c$bvl+1 # unary operator with value operand
2506: .set c$alt,c$uvl+1 # alternation (binary bar)
2507: .set c$cnc,c$alt+1 # concatenation
2508: .set c$cnp,c$cnc+1 # concatenation, not pattern match
2509: .set c$unm,c$cnp+1 # unary op with name operand
2510: .set c$bvn,c$unm+1 # binary op (operands by value, name)
2511: .set c$ass,c$bvn+1 # assignment
2512: .set c$int,c$ass+1 # interrogation
2513: .set c$neg,c$int+1 # negation (unary not)
2514: .set c$sel,c$neg+1 # selection
2515: .set c$pmt,c$sel+1 # pattern match
2516: #
2517: .set c$pr$,c$bvn # last preevaluable code
2518: .set c$$nv,c$pmt+1 # number of different cmblk types
2519: #page
2520: #
2521: # CHARACTER TABLE BLOCK (CTBLK)
2522: #
2523: # A CHARACTER TABLE BLOCK IS USED TO HOLD LOGICAL CHARACTER
2524: # TABLES FOR USE WITH ANY,NOTANY,SPAN,BREAK,BREAKX
2525: # PATTERNS. EACH CHARACTER TABLE CAN BE USED TO STORE
2526: # CFP$N DISTINCT TABLES AS BIT COLUMNS. A BIT COLUMN
2527: # ALLOCATED FOR EACH ARGUMENT OF MORE THAN ONE CHARACTER
2528: # IN LENGTH TO ONE OF THE ABOVE LISTED PATTERN PRIMITIVES.
2529: #
2530: # +------------------------------------+
2531: # I CTTYP I
2532: # +------------------------------------+
2533: # * *
2534: # * *
2535: # * CTCHS *
2536: # * *
2537: # * *
2538: # +------------------------------------+
2539: #
2540: .set cttyp,0 # pointer to dummy routine b$ctt
2541: .set ctchs,cttyp+1 # start of character table words
2542: .set ctsi$,ctchs+cfp$a# number of words in ctblk
2543: #
2544: # CTCHS IS CFP$A WORDS LONG AND CONSISTS OF A ONE WORD
2545: # BIT STRING VALUE FOR EACH POSSIBLE CHARACTER IN THE
2546: # INTERNAL ALPHABET. EACH OF THE CFP$N POSSIBLE BITS IN
2547: # A BITSTRING IS USED TO FORM A COLUMN OF BIT INDICATORS.
2548: # A BIT IS SET ON IF THE CHARACTER IS IN THE TABLE AND OFF
2549: # IF THE CHARACTER IS NOT PRESENT.
2550: #page
2551: #
2552: # DATATYPE FUNCTION BLOCK (DFBLK)
2553: #
2554: # A DATATYPE FUNCTION IS USED TO CONTROL THE CONSTRUCTION
2555: # OF A PROGRAM DEFINED DATATYPE OBJECT. A CALL TO THE
2556: # SYSTEM FUNCTION DATA BUILDS A DFBLK FOR THE DATATYPE NAME
2557: #
2558: # NOTE THAT THESE BLOCKS ARE BUILT IN STATIC BECAUSE PDBLK
2559: # LENGTH IS GOT FROM DFLEN FIELD. IF DFBLK WAS IN DYNAMIC
2560: # STORE THIS WOULD CAUSE TROUBLE DURING PASS TWO OF GARBAGE
2561: # COLLECTION. SCBLK REFERRED TO BY DFNAM FIELD IS ALSO PUT
2562: # IN STATIC SO THAT THERE ARE NO RELOC. FIELDS. THIS CUTS
2563: # GARBAGE COLLECTION TASK APPRECIABLY FOR PDBLKS WHICH ARE
2564: # LIKELY TO BE PRESENT IN LARGE NUMBERS.
2565: #
2566: # +------------------------------------+
2567: # I FCODE I
2568: # +------------------------------------+
2569: # I FARGS I
2570: # +------------------------------------+
2571: # I DFLEN I
2572: # +------------------------------------+
2573: # I DFPDL I
2574: # +------------------------------------+
2575: # I DFNAM I
2576: # +------------------------------------+
2577: # / /
2578: # / DFFLD /
2579: # / /
2580: # +------------------------------------+
2581: #
2582: .set dflen,fargs+1 # length of dfblk in bytes
2583: .set dfpdl,dflen+1 # length of corresponding pdblk
2584: .set dfnam,dfpdl+1 # pointer to scblk for datatype name
2585: .set dffld,dfnam+1 # start of vrblk ptrs for field names
2586: .set dfflb,dffld-1 # offset behind dffld for field func
2587: .set dfsi$,dffld # number of standard fields in dfblk
2588: #
2589: # THE FCODE FIELD POINTS TO THE ROUTINE B$DFC
2590: #
2591: # FARGS (THE NUMBER OF ARGUMENTS) IS THE NUMBER OF FIELDS.
2592: #page
2593: #
2594: # DOPE VECTOR BLOCK (DVBLK)
2595: #
2596: # A DOPE VECTOR IS ASSEMBLED FOR EACH POSSIBLE OPERATOR IN
2597: # THE SNOBOL4 LANGUAGE AS PART OF THE CONSTANT SECTION.
2598: #
2599: # +------------------------------------+
2600: # I DVOPN I
2601: # +------------------------------------+
2602: # I DVTYP I
2603: # +------------------------------------+
2604: # I DVLPR I
2605: # +------------------------------------+
2606: # I DVRPR I
2607: # +------------------------------------+
2608: #
2609: .set dvopn,0 # entry address (ptr to o$xxx)
2610: .set dvtyp,dvopn+1 # type code (c$xxx, see cmblk)
2611: .set dvlpr,dvtyp+1 # left precedence (llxxx, see below)
2612: .set dvrpr,dvlpr+1 # right precedence (rrxxx, see below)
2613: .set dvus$,dvlpr+1 # size of unary operator dv
2614: .set dvbs$,dvrpr+1 # size of binary operator dv
2615: .set dvubs,dvus$+dvbs$# size of unop + binop (see scane)
2616: #
2617: # THE CONTENTS OF THE DVTYP FIELD IS COPIED INTO THE CMTYP
2618: # FIELD OF THE CMBLK FOR THE OPERATOR IF IT IS USED.
2619: #
2620: # THE CMOPN FIELD OF AN OPERATOR CMBLK POINTS TO THE DVBLK
2621: # ITSELF, PROVIDING THE REQUIRED ENTRY ADDRESS POINTER PTR.
2622: #
2623: # FOR NORMALLY UNDEFINED OPERATORS, THE DVOPN (AND CMOPN)
2624: # FIELDS CONTAIN A WORD OFFSET FROM R$UBA OF THE FUNCTION
2625: # BLOCK POINTER FOR THE OPERATOR (INSTEAD OF O$XXX PTR).
2626: # FOR CERTAIN SPECIAL OPERATORS, THE DVOPN FIELD IS NOT
2627: # REQUIRED AT ALL AND IS ASSEMBLED AS ZERO.
2628: #
2629: # THE LEFT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO
2630: # THE LEFT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS THE
2631: # PRECEDENCE OF THE OPERATOR TOWARDS ITS RIGHT OPERAND.
2632: #
2633: # THE RIGHT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO
2634: # THE RIGHT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS
2635: # THE PRECEDENCE OF THE OPERATOR TOWARDS ITS LEFT OPERAND.
2636: #
2637: # HIGHER PRECEDENCE VALUES CORRESPOND TO A TIGHTER BINDING
2638: # CAPABILITY. THUS WE HAVE THE LEFT PRECEDENCE LOWER
2639: # (HIGHER) THAN THE RIGHT PRECEDENCE FOR RIGHT (LEFT)
2640: # ASSOCIATIVE BINARY OPERATORS.
2641: #
2642: # THE LEFT PRECEDENCE OF UNARY OPERATORS IS SET TO AN
2643: # ARBITRARY HIGH VALUE. THE RIGHT VALUE IS NOT REQUIRED AND
2644: # CONSEQUENTLY THE DVRPR FIELD IS OMITTED FOR UNARY OPS.
2645: #page
2646: #
2647: # TABLE OF OPERATOR PRECEDENCE VALUES
2648: #
2649: .set rrass,10 # right equal
2650: .set llass,00 # left equal
2651: .set rrpmt,20 # right question mark
2652: .set llpmt,30 # left question mark
2653: .set rramp,40 # right ampersand
2654: .set llamp,50 # left ampersand
2655: .set rralt,70 # right vertical bar
2656: .set llalt,60 # left vertical bar
2657: .set rrcnc,90 # right blank
2658: .set llcnc,80 # left blank
2659: .set rrats,110 # right at
2660: .set llats,100 # left at
2661: .set rrplm,120 # right plus, minus
2662: .set llplm,130 # left plus, minus
2663: .set rrnum,140 # right number
2664: .set llnum,150 # left number
2665: .set rrdvd,160 # right slash
2666: .set lldvd,170 # left slash
2667: .set rrmlt,180 # right asterisk
2668: .set llmlt,190 # left asterisk
2669: .set rrpct,200 # right percent
2670: .set llpct,210 # left percent
2671: .set rrexp,230 # right exclamation
2672: .set llexp,220 # left exclamation
2673: .set rrdld,240 # right dollar, dot
2674: .set lldld,250 # left dollar, dot
2675: .set rrnot,270 # right not
2676: .set llnot,260 # left not
2677: .set lluno,999 # left all unary operators
2678: #
2679: # PRECEDENCES ARE THE SAME AS IN BTL SNOBOL4 WITH THE
2680: # FOLLOWING EXCEPTIONS.
2681: #
2682: # 1) BINARY QUESTION MARK IS LOWERED AND MADE LEFT ASSOC-
2683: # IATIVE TO REFLECT ITS NEW USE FOR PATTERN MATCHING.
2684: #
2685: # 2) ALTERNATION AND CONCATENATION ARE MADE RIGHT
2686: # ASSOCIATIVE FOR GREATER EFFICIENCY IN PATTERN
2687: # CONSTRUCTION AND MATCHING RESPECTIVELY. THIS CHANGE
2688: # IS TRANSPARENT TO THE SNOBOL4 PROGRAMMER.
2689: #
2690: # 3) THE EQUAL SIGN HAS BEEN ADDED AS A LOW PRECEDENCE
2691: # OPERATOR WHICH IS RIGHT ASSOCIATIVE TO REFLECT ITS
2692: # MORE GENERAL USAGE IN THIS VERSION OF SNOBOL4.
2693: #page
2694: #
2695: # EXTERNAL FUNCTION BLOCK (EFBLK)
2696: #
2697: # AN EXTERNAL FUNCTION BLOCK IS USED TO CONTROL THE CALLING
2698: # OF AN EXTERNAL FUNCTION. IT IS BUILT BY A CALL TO LOAD.
2699: #
2700: # +------------------------------------+
2701: # I FCODE I
2702: # +------------------------------------+
2703: # I FARGS I
2704: # +------------------------------------+
2705: # I EFLEN I
2706: # +------------------------------------+
2707: # I EFUSE I
2708: # +------------------------------------+
2709: # I EFCOD I
2710: # +------------------------------------+
2711: # I EFVAR I
2712: # +------------------------------------+
2713: # I EFRSL I
2714: # +------------------------------------+
2715: # / /
2716: # / EFTAR /
2717: # / /
2718: # +------------------------------------+
2719: #
2720: .set eflen,fargs+1 # length of efblk in bytes
2721: .set efuse,eflen+1 # use count (for opsyn)
2722: .set efcod,efuse+1 # ptr to code (from sysld)
2723: .set efvar,efcod+1 # ptr to associated vrblk
2724: .set efrsl,efvar+1 # result type (see below)
2725: .set eftar,efrsl+1 # argument types (see below)
2726: .set efsi$,eftar # number of standard fields in efblk
2727: #
2728: # THE FCODE FIELD POINTS TO THE ROUTINE B$EFC.
2729: #
2730: # EFUSE IS USED TO KEEP TRACK OF MULTIPLE USE WHEN OPSYN
2731: # IS EMPLOYED. THE FUNCTION IS AUTOMATICALLY UNLOADED
2732: # WHEN THERE ARE NO MORE REFERENCES TO THE FUNCTION.
2733: #
2734: # EFRSL AND EFTAR ARE TYPE CODES AS FOLLOWS.
2735: #
2736: # 0 TYPE IS UNCONVERTED
2737: # 1 TYPE IS STRING
2738: # 2 TYPE IS INTEGER
2739: # 3 TYPE IS REAL
2740: #page
2741: #
2742: # EXPRESSION VARIABLE BLOCK (EVBLK)
2743: #
2744: # IN THIS VERSION OF SPITBOL, AN EXPRESSION CAN BE USED IN
2745: # ANY POSITION WHICH WOULD NORMALLY EXPECT A NAME (FOR
2746: # EXAMPLE ON THE LEFT SIDE OF EQUALS OR AS THE RIGHT
2747: # ARGUMENT OF BINARY DOT). THIS CORRESPONDS TO THE CREATION
2748: # OF A PSEUDO-VARIABLE WHICH IS REPRESENTED BY A POINTER TO
2749: # AN EXPRESSION VARIABLE BLOCK AS FOLLOWS.
2750: #
2751: # +------------------------------------+
2752: # I EVTYP I
2753: # +------------------------------------+
2754: # I EVEXP I
2755: # +------------------------------------+
2756: # I EVVAR I
2757: # +------------------------------------+
2758: #
2759: .set evtyp,0 # pointer to dummy routine b$evt
2760: .set evexp,evtyp+1 # pointer to exblk for expression
2761: .set evvar,evexp+1 # pointer to trbev dummy trblk
2762: .set evsi$,evvar+1 # size of evblk
2763: #
2764: # THE NAME OF AN EXPRESSION VARIABLE IS REPRESENTED BY A
2765: # BASE POINTER TO THE EVBLK AND AN OFFSET OF EVVAR. THIS
2766: # VALUE APPEARS TO BE TRAPPED BY THE DUMMY TRBEV BLOCK.
2767: #
2768: # NOTE THAT THERE IS NO NEED TO ALLOW FOR THE CASE OF AN
2769: # EXPRESSION VARIABLE WHICH REFERENCES AN SEBLK SINCE A
2770: # VARIABLE WHICH IS OF THE FORM *VAR IS EQUIVALENT TO VAR.
2771: #page
2772: #
2773: # EXPRESSION BLOCK (EXBLK)
2774: #
2775: # AN EXPRESSION BLOCK IS BUILT FOR EACH EXPRESSION
2776: # REFERENCED IN A PROGRAM OR CREATED BY EVAL OR CONVERT
2777: # DURING EXECUTION OF A PROGRAM.
2778: #
2779: # +------------------------------------+
2780: # I EXTYP I
2781: # +------------------------------------+
2782: # I EXSTM I
2783: # +------------------------------------+
2784: # I EXLEN I
2785: # +------------------------------------+
2786: # I EXFLC I
2787: # +------------------------------------+
2788: # / /
2789: # / EXCOD /
2790: # / /
2791: # +------------------------------------+
2792: #
2793: .set extyp,0 # ptr to routine b$exl to load expr
2794: .set exstm,cdstm # stores stmnt no. during evaluation
2795: .set exlen,exstm+1 # length of exblk in bytes
2796: .set exflc,exlen+1 # failure code (=o$fex)
2797: .set excod,exflc+1 # pseudo-code for expression
2798: .set exsi$,excod # number of standard fields in exblk
2799: #
2800: # THERE ARE TWO CASES FOR EXCOD DEPENDING ON WHETHER THE
2801: # EXPRESSION CAN BE EVALUATED BY NAME (SEE DESCRIPTION
2802: # OF CDBLK FOR DETAILS OF CODE FOR EXPRESSIONS).
2803: #
2804: # IF THE EXPRESSION CAN BE EVALUATED BY NAME WE HAVE.
2805: #
2806: # (CODE FOR EXPR BY NAME)
2807: # =O$RNM
2808: #
2809: # IF THE EXPRESSION CAN ONLY BE EVALUATED BY VALUE.
2810: #
2811: # (CODE FOR EXPR BY VALUE)
2812: # =O$RVL
2813: #page
2814: #
2815: # FIELD FUNCTION BLOCK (FFBLK)
2816: #
2817: # A FIELD FUNCTION BLOCK IS USED TO CONTROL THE SELECTION
2818: # OF A FIELD FROM A PROGRAM DEFINED DATATYPE BLOCK.
2819: # A CALL TO DATA CREATES AN FFBLK FOR EACH FIELD.
2820: #
2821: # +------------------------------------+
2822: # I FCODE I
2823: # +------------------------------------+
2824: # I FARGS I
2825: # +------------------------------------+
2826: # I FFDFP I
2827: # +------------------------------------+
2828: # I FFNXT I
2829: # +------------------------------------+
2830: # I FFOFS I
2831: # +------------------------------------+
2832: #
2833: .set ffdfp,fargs+1 # pointer to associated dfblk
2834: .set ffnxt,ffdfp+1 # ptr to next ffblk on chain or zero
2835: .set ffofs,ffnxt+1 # offset (bytes) to field in pdblk
2836: .set ffsi$,ffofs+1 # size of ffblk in words
2837: #
2838: # THE FCODE FIELD POINTS TO THE ROUTINE B$FFC.
2839: #
2840: # FARGS ALWAYS CONTAINS ONE.
2841: #
2842: # FFDFP IS USED TO VERIFY THAT THE CORRECT PROGRAM DEFINED
2843: # DATATYPE IS BEING ACCESSED BY THIS CALL.
2844: # FFDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC
2845: #
2846: # FFOFS IS USED TO SELECT THE APPROPRIATE FIELD. NOTE THAT
2847: # IT IS AN ACTUAL OFFSET (NOT A FIELD NUMBER)
2848: #
2849: # FFNXT IS USED TO POINT TO THE NEXT FFBLK OF THE SAME NAME
2850: # IN THE CASE WHERE THERE ARE SEVERAL FIELDS OF THE SAME
2851: # NAME FOR DIFFERENT DATATYPES. ZERO MARKS THE END OF CHAIN
2852: #page
2853: #
2854: # INTEGER CONSTANT BLOCK (ICBLK)
2855: #
2856: # AN ICBLK IS CREATED FOR EVERY INTEGER REFERENCED OR
2857: # CREATED BY A PROGRAM. NOTE HOWEVER THAT CERTAIN INTERNAL
2858: # INTEGER VALUES ARE STORED AS ADDRESSES (E.G. THE LENGTH
2859: # FIELD IN A STRING CONSTANT BLOCK)
2860: #
2861: # +------------------------------------+
2862: # I ICGET I
2863: # +------------------------------------+
2864: # * ICVAL *
2865: # +------------------------------------+
2866: #
2867: .set icget,0 # ptr to routine b$icl to load int
2868: .set icval,icget+1 # integer value
2869: .set icsi$,icval+cfp$i# size of icblk
2870: #
2871: # THE LENGTH OF THE ICVAL FIELD IS CFP$I.
2872: #page
2873: #
2874: # KEYWORD VARIABLE BLOCK (KVBLK)
2875: #
2876: # A KVBLK IS USED TO REPRESENT A KEYWORD PSEUDO-VARIABLE.
2877: # A KVBLK IS BUILT FOR EACH KEYWORD REFERENCE (KWNAM).
2878: #
2879: # +------------------------------------+
2880: # I KVTYP I
2881: # +------------------------------------+
2882: # I KVVAR I
2883: # +------------------------------------+
2884: # I KVNUM I
2885: # +------------------------------------+
2886: #
2887: .set kvtyp,0 # pointer to dummy routine b$kvt
2888: .set kvvar,kvtyp+1 # pointer to dummy block trbkv
2889: .set kvnum,kvvar+1 # keyword number
2890: .set kvsi$,kvnum+1 # size of kvblk
2891: #
2892: # THE NAME OF A KEYWORD VARIABLE IS REPRESENTED BY A
2893: # BASE POINTER TO THE KVBLK AND AN OFFSET OF KVVAR. THE
2894: # VALUE APPEARS TO BE TRAPPED BY THE POINTER TO TRBKV.
2895: #page
2896: #
2897: # NAME BLOCK (NMBLK)
2898: #
2899: # A NAME BLOCK IS USED WHEREVER A NAME MUST BE STORED AS
2900: # A VALUE FOLLOWING USE OF THE UNARY DOT OPERATOR.
2901: #
2902: # +------------------------------------+
2903: # I NMTYP I
2904: # +------------------------------------+
2905: # I NMBAS I
2906: # +------------------------------------+
2907: # I NMOFS I
2908: # +------------------------------------+
2909: #
2910: .set nmtyp,0 # ptr to routine b$nml to load name
2911: .set nmbas,nmtyp+1 # base pointer for variable
2912: .set nmofs,nmbas+1 # offset for variable
2913: .set nmsi$,nmofs+1 # size of nmblk
2914: #
2915: # THE ACTUAL FIELD REPRESENTING THE CONTENTS OF THE NAME
2916: # IS FOUND NMOFS BYTES PAST THE ADDRESS IN NMBAS.
2917: #
2918: # THE NAME IS SPLIT INTO BASE AND OFFSET FORM TO AVOID
2919: # CREATION OF A POINTER INTO THE MIDDLE OF A BLOCK WHICH
2920: # COULD NOT BE HANDLED PROPERLY BY THE GARBAGE COLLECTOR.
2921: #
2922: # A NAME MAY BE BUILT FOR ANY VARIABLE (SEE SECTION ON
2923: # REPRESENTATIONS OF VARIABLES) THIS INCLUDES THE
2924: # CASES OF PSEUDO-VARIABLES.
2925: #page
2926: #
2927: # PATTERN BLOCK, NO PARAMETERS (P0BLK)
2928: #
2929: # A P0BLK IS USED TO REPRESENT PATTERN NODES WHICH DO
2930: # NOT REQUIRE THE USE OF ANY PARAMETER VALUES.
2931: #
2932: # +------------------------------------+
2933: # I PCODE I
2934: # +------------------------------------+
2935: # I PTHEN I
2936: # +------------------------------------+
2937: #
2938: .set pcode,0 # ptr to match routine (p$xxx)
2939: .set pthen,pcode+1 # pointer to subsequent node
2940: .set pasi$,pthen+1 # size of p0blk
2941: #
2942: # PTHEN POINTS TO THE PATTERN BLOCK FOR THE SUBSEQUENT
2943: # NODE TO BE MATCHED. THIS IS A POINTER TO THE PATTERN
2944: # BLOCK NDNTH IF THERE IS NO SUBSEQUENT (END OF PATTERN)
2945: #
2946: # PCODE IS A POINTER TO THE MATCH ROUTINE FOR THE NODE.
2947: #page
2948: #
2949: # PATTERN BLOCK (ONE PARAMETER)
2950: #
2951: # A P1BLK IS USED TO REPRESENT PATTERN NODES WHICH
2952: # REQUIRE ONE PARAMETER VALUE.
2953: #
2954: # +------------------------------------+
2955: # I PCODE I
2956: # +------------------------------------+
2957: # I PTHEN I
2958: # +------------------------------------+
2959: # I PARM1 I
2960: # +------------------------------------+
2961: #
2962: .set parm1,pthen+1 # first parameter value
2963: .set pbsi$,parm1+1 # size of p1blk in words
2964: #
2965: # SEE P0BLK FOR DEFINITIONS OF PCODE, PTHEN
2966: #
2967: # PARM1 CONTAINS A PARAMETER VALUE USED IN MATCHING THE
2968: # NODE. FOR EXAMPLE, IN A LEN PATTERN, IT IS THE INTEGER
2969: # ARGUMENT TO LEN. THE DETAILS OF THE USE OF THE PARAMETER
2970: # FIELD ARE INCLUDED IN THE DESCRIPTION OF THE INDIVIDUAL
2971: # MATCH ROUTINES. PARM1 IS ALWAYS AN ADDRESS POINTER WHICH
2972: # IS PROCESSED BY THE GARBAGE COLLECTOR.
2973: #page
2974: #
2975: # PATTERN BLOCK (TWO PARAMETERS)
2976: #
2977: # A P2BLK IS USED TO REPRESENT PATTERN NODES WHICH
2978: # REQUIRE TWO PARAMETER VALUES.
2979: #
2980: # +------------------------------------+
2981: # I PCODE I
2982: # +------------------------------------+
2983: # I PTHEN I
2984: # +------------------------------------+
2985: # I PARM1 I
2986: # +------------------------------------+
2987: # I PARM2 I
2988: # +------------------------------------+
2989: #
2990: .set parm2,parm1+1 # second parameter value
2991: .set pcsi$,parm2+1 # size of p2blk in words
2992: #
2993: # SEE P1BLK FOR DEFINITIONS OF PCODE, PTHEN, PARM1
2994: #
2995: # PARM2 IS A PARAMETER WHICH PERFORMS THE SAME SORT OF
2996: # FUNCTION AS PARM1 (SEE DESCRIPTION OF P1BLK).
2997: #
2998: # PARM2 IS A NON-RELOCATABLE FIELD AND IS NOT
2999: # PROCESSED BY THE GARBAGE COLLECTOR. ACCORDINGLY, IT MAY
3000: # NOT CONTAIN A POINTER TO A BLOCK IN DYNAMIC MEMORY.
3001: #page
3002: #
3003: # PROGRAM-DEFINED DATATYPE BLOCK
3004: #
3005: # A PDBLK REPRESENTS THE DATA ITEM FORMED BY A CALL TO A
3006: # DATATYPE FUNCTION AS DEFINED BY THE SYSTEM FUNCTION DATA.
3007: #
3008: # +------------------------------------+
3009: # I PDTYP I
3010: # +------------------------------------+
3011: # I IDVAL I
3012: # +------------------------------------+
3013: # I PDDFP I
3014: # +------------------------------------+
3015: # / /
3016: # / PDFLD /
3017: # / /
3018: # +------------------------------------+
3019: #
3020: .set pdtyp,0 # ptr to dummy routine b$pdt
3021: .set pddfp,idval+1 # ptr to associated dfblk
3022: .set pdfld,pddfp+1 # start of field value pointers
3023: .set pdfof,dffld-pdfld# difference in offset to field ptrs
3024: .set pdsi$,pdfld # size of standard fields in pdblk
3025: .set pddfs,dfsi$-pdsi$# difference in dfblk, pdblk sizes
3026: #
3027: # THE PDDFP POINTER MAY BE USED TO DETERMINE THE DATATYPE
3028: # AND THE NAMES OF THE FIELDS IF REQUIRED. THE DFBLK ALSO
3029: # CONTAINS THE LENGTH OF THE PDBLK IN BYTES (FIELD DFPDL).
3030: # PDDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC
3031: #
3032: # PDFLD VALUES ARE STORED IN ORDER FROM LEFT TO RIGHT.
3033: # THEY CONTAIN VALUES OR POINTERS TO TRBLK CHAINS.
3034: #page
3035: #
3036: # PROGRAM DEFINED FUNCTION BLOCK (PFBLK)
3037: #
3038: # A PFBLK IS CREATED FOR EACH CALL TO THE DEFINE FUNCTION
3039: # AND A POINTER TO THE PFBLK PLACED IN THE PROPER VRBLK.
3040: #
3041: # +------------------------------------+
3042: # I FCODE I
3043: # +------------------------------------+
3044: # I FARGS I
3045: # +------------------------------------+
3046: # I PFLEN I
3047: # +------------------------------------+
3048: # I PFVBL I
3049: # +------------------------------------+
3050: # I PFNLO I
3051: # +------------------------------------+
3052: # I PFCOD I
3053: # +------------------------------------+
3054: # I PFCTR I
3055: # +------------------------------------+
3056: # I PFRTR I
3057: # +------------------------------------+
3058: # / /
3059: # / PFARG /
3060: # / /
3061: # +------------------------------------+
3062: #
3063: .set pflen,fargs+1 # length of pfblk in bytes
3064: .set pfvbl,pflen+1 # pointer to vrblk for function name
3065: .set pfnlo,pfvbl+1 # number of locals
3066: .set pfcod,pfnlo+1 # ptr to cdblk for first statement
3067: .set pfctr,pfcod+1 # trblk ptr if call traced else 0
3068: .set pfrtr,pfctr+1 # trblk ptr if return traced else 0
3069: .set pfarg,pfrtr+1 # vrblk ptrs for arguments and locals
3070: .set pfagb,pfarg-1 # offset behind pfarg for arg, local
3071: .set pfsi$,pfarg # number of standard fields in pfblk
3072: #
3073: # THE FCODE FIELD POINTS TO THE ROUTINE B$PFC.
3074: #
3075: # PFARG IS STORED IN THE FOLLOWING ORDER.
3076: #
3077: # ARGUMENTS (LEFT TO RIGHT)
3078: # LOCALS (LEFT TO RIGHT)
3079: #page
3080: #
3081: # REAL CONSTANT BLOCK (RCBLK)
3082: #
3083: # AN RCBLK IS CREATED FOR EVERY REAL REFERENCED OR
3084: # CREATED BY A PROGRAM.
3085: #
3086: # +------------------------------------+
3087: # I RCGET I
3088: # +------------------------------------+
3089: # * RCVAL *
3090: # +------------------------------------+
3091: #
3092: .set rcget,0 # ptr to routine b$rcl to load real
3093: .set rcval,rcget+1 # real value
3094: .set rcsi$,rcval+cfp$r# size of rcblk
3095: #
3096: # THE LENGTH OF THE RCVAL FIELD IS CFP$R.
3097: #page
3098: #
3099: # STRING CONSTANT BLOCK (SCBLK)
3100: #
3101: # AN SCBLK IS BUILT FOR EVERY STRING REFERENCED OR CREATED
3102: # BY A PROGRAM.
3103: #
3104: # +------------------------------------+
3105: # I SCGET I
3106: # +------------------------------------+
3107: # I SCLEN I
3108: # +------------------------------------+
3109: # / /
3110: # / SCHAR /
3111: # / /
3112: # +------------------------------------+
3113: #
3114: .set scget,0 # ptr to routine b$scl to load string
3115: .set sclen,scget+1 # length of string in characters
3116: .set schar,sclen+1 # characters of string
3117: .set scsi$,schar # size of standard fields in scblk
3118: #
3119: # THE CHARACTERS OF THE STRING ARE STORED LEFT JUSTIFIED.
3120: # THE FINAL WORD IS PADDED ON THE RIGHT WITH ZEROS.
3121: # (I.E. THE CHARACTER WHOSE INTERNAL CODE IS ZERO).
3122: #
3123: # THE VALUE OF SCLEN MAY NOT EXCEED MXLEN. THIS ENSURES
3124: # THAT CHARACTER OFFSETS (E.G. THE PATTERN MATCH CURSOR)
3125: # CAN BE CORRECTLY PROCESSED BY THE GARBAGE COLLECTOR.
3126: #
3127: # NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING
3128: # IS GIVEN IN BYTES BY CFP$F AND THAT THIS VALUE IS
3129: # AUTOMATICALLY ALLOWED FOR IN PLC, PSC.
3130: # NOTE THAT FOR A SPITBOL SCBLK, THE VALUE OF CFP$F
3131: # IS GIVEN BY CFP$B*SCHAR.
3132: #page
3133: #
3134: # SIMPLE EXPRESSION BLOCK (SEBLK)
3135: #
3136: # AN SEBLK IS USED TO REPRESENT AN EXPRESSION OF THE FORM
3137: # *(NATURAL VARIABLE). ALL OTHER EXPRESSIONS ARE EXBLKS.
3138: #
3139: # +------------------------------------+
3140: # I SETYP I
3141: # +------------------------------------+
3142: # I SEVAR I
3143: # +------------------------------------+
3144: #
3145: .set setyp,0 # ptr to routine b$sel to load expr
3146: .set sevar,setyp+1 # ptr to vrblk for variable
3147: .set sesi$,sevar+1 # length of seblk in words
3148: #page
3149: #
3150: # STANDARD VARIABLE BLOCK (SVBLK)
3151: #
3152: # AN SVBLK IS ASSEMBLED IN THE CONSTANT SECTION FOR EACH
3153: # VARIABLE WHICH SATISFIES ONE OF THE FOLLOWING CONDITIONS.
3154: #
3155: # 1) IT IS THE NAME OF A SYSTEM FUNCTION
3156: # 2) IT HAS AN INITIAL VALUE
3157: # 3) IT HAS A KEYWORD ASSOCIATION
3158: # 4) IT HAS A STANDARD I/O ASSOCIATION
3159: # 6) IT HAS A STANDARD LABEL ASSOCIATION
3160: #
3161: # IF VRBLKS ARE CONSTRUCTED FOR ANY OF THESE VARIABLES,
3162: # THEN THE VRSVP FIELD POINTS TO THE SVBLK (SEE VRBLK)
3163: #
3164: # +------------------------------------+
3165: # I SVBIT I
3166: # +------------------------------------+
3167: # I SVLEN I
3168: # +------------------------------------+
3169: # I SVCHS I
3170: # +------------------------------------+
3171: # I SVKNM I
3172: # +------------------------------------+
3173: # I SVFNC I
3174: # +------------------------------------+
3175: # I SVNAR I
3176: # +------------------------------------+
3177: # I SVLBL I
3178: # +------------------------------------+
3179: # I SVVAL I
3180: # +------------------------------------+
3181: #page
3182: #
3183: # STANDARD VARIABLE BLOCK (CONTINUED)
3184: #
3185: .set svbit,0 # bit string indicating attributes
3186: .set svlen,1 # (=sclen) length of name in chars
3187: .set svchs,2 # (=schar) characters of name
3188: .set svsi$,2 # number of standard fields in svblk
3189: .set svpre,1 # set if preevaluation permitted
3190: .set svffc,svpre+svpre# set on if fast call permitted
3191: .set svckw,svffc+svffc# set on if keyword value constant
3192: .set svprd,svckw+svckw# set on if predicate function
3193: .set svnbt,4 # number of bits to right of svknm
3194: .set svknm,svprd+svprd# set on if keyword association
3195: .set svfnc,svknm+svknm# set on if system function
3196: .set svnar,svfnc+svfnc# set on if system function
3197: .set svlbl,svnar+svnar# set on if system label
3198: .set svval,svlbl+svlbl# set on if predefined value
3199: #
3200: # NOTE THAT THE LAST FIVE BITS CORRESPOND IN ORDER
3201: # TO THE FIELDS WHICH ARE PRESENT (SEE PROCEDURE GTNVR).
3202: #
3203: # THE FOLLOWING DEFINITIONS ARE USED IN THE SVBLK TABLE
3204: #
3205: .set svfnf,svfnc+svnar# function with no fast call
3206: .set svfnn,svfnf+svffc# function with fast call, no preeval
3207: .set svfnp,svfnn+svpre# function allowing preevaluation
3208: .set svfpr,svfnn+svprd# predicate function
3209: .set svfnk,svfnn+svknm# no preeval func + keyword
3210: .set svkwv,svknm+svval# keyword + value
3211: .set svkwc,svckw+svknm# keyword with constant value
3212: .set svkvc,svkwv+svckw# constant keyword + value
3213: .set svkvl,svkvc+svlbl# constant keyword + value + label
3214: .set svfpk,svfnp+svkvc# preeval fcn + const keywd + val
3215: #
3216: # THE SVPRE BIT ALLOWS THE COMPILER TO PREEVALUATE A CALL
3217: # TO THE ASSOCIATED SYSTEM FUNCTION IF ALL THE ARGUMENTS
3218: # ARE THEMSELVES CONSTANTS. FUNCTIONS IN THIS CATEGORY
3219: # MUST HAVE NO SIDE EFFECTS AND MUST NEVER CAUSE FAILURE.
3220: # THE CALL MAY GENERATE AN ERROR CONDITION.
3221: #
3222: # THE SVFFC BIT ALLOWS THE COMPILER TO GENERATE THE SPECIAL
3223: # FAST CALL AFTER ADJUSTING THE NUMBER OF ARGUMENTS. ONLY
3224: # THE ITEM AND APPLY FUNCTIONS FALL OUTSIDE THIS CATEGORY.
3225: #
3226: # THE SVCKW BIT IS SET IF THE ASSOCIATED KEYWORD VALUE IS
3227: # A CONSTANT, THUS ALLOWING PREEVALUATION FOR A VALUE CALL.
3228: #
3229: # THE SVPRD BIT IS SET ON FOR ALL PREDICATE FUNCTIONS TO
3230: # ENABLE THE SPECIAL CONCATENATION CODE OPTIMIZATION.
3231: #page
3232: #
3233: # SVBLK (CONTINUED)
3234: #
3235: # SVKNM KEYWORD NUMBER
3236: #
3237: # SVKNM IS PRESENT ONLY FOR A STANDARD KEYWORD ASSOC.
3238: # IT CONTAINS A KEYWORD NUMBER AS DEFINED BY THE
3239: # KEYWORD NUMBER TABLE GIVEN LATER ON.
3240: #
3241: # SVFNC SYSTEM FUNCTION POINTER
3242: #
3243: # SVFNC IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC.
3244: # IT IS A POINTER TO THE ACTUAL CODE FOR THE SYSTEM
3245: # FUNCTION. THE GENERATED CODE FOR A FAST CALL IS A
3246: # POINTER TO THE SVFNC FIELD OF THE SVBLK FOR THE
3247: # FUNCTION. THE VRFNC FIELD OF THE VRBLK POINTS TO
3248: # THIS SAME FIELD, IN WHICH CASE, IT SERVES AS THE
3249: # FCODE FIELD FOR THE FUNCTION CALL.
3250: #
3251: # SVNAR NUMBER OF FUNCTION ARGUMENTS
3252: #
3253: # SVNAR IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC.
3254: # IT IS THE NUMBER OF ARGUMENTS REQUIRED FOR A CALL
3255: # TO THE SYSTEM FUNCTION. THE COMPILER USES THIS
3256: # VALUE TO ADJUST THE NUMBER OF ARGUMENTS IN A FAST
3257: # CALL AND IN THE CASE OF A FUNCTION CALLED THROUGH
3258: # THE VRFNC FIELD OF THE VRBLK, THE SVNAR FIELD
3259: # SERVES AS THE FARGS FIELD FOR O$FNC. A SPECIAL
3260: # CASE OCCURS IF THIS VALUE IS SET TO 999. THIS IS
3261: # USED TO INDICATE THAT THE FUNCTION HAS A VARIABLE
3262: # NUMBER OF ARGUMENTS AND CAUSES O$FNC TO PASS CONTROL
3263: # WITHOUT ADJUSTING THE ARGUMENT COUNT. THE ONLY
3264: # PREDEFINED FUNCTIONS USING THIS ARE APPLY AND ITEM.
3265: #
3266: # SVLBL SYSTEM LABEL POINTER
3267: #
3268: # SVLBL IS PRESENT ONLY FOR A STANDARD LABEL ASSOC.
3269: # IT IS A POINTER TO A SYSTEM LABEL ROUTINE (L$XXX).
3270: # THE VRLBL FIELD OF THE CORRESPONDING VRBLK POINTS TO
3271: # THE SVLBL FIELD OF THE SVBLK.
3272: #
3273: # SVVAL SYSTEM VALUE POINTER
3274: #
3275: # SVVAL IS PRESENT ONLY FOR A STANDARD VALUE.
3276: # IT IS A POINTER TO THE PATTERN NODE (NDXXX) WHICH
3277: # IS THE STANDARD INITIAL VALUE OF THE VARIABLE.
3278: # THIS VALUE IS COPIED TO THE VRVAL FIELD OF THE VRBLK
3279: #page
3280: #
3281: # SVBLK (CONTINUED)
3282: #
3283: # KEYWORD NUMBER TABLE
3284: #
3285: # THE FOLLOWING TABLE GIVES SYMBOLIC NAMES FOR KEYWORD
3286: # NUMBERS. THESE VALUES ARE STORED IN THE SVKNM FIELD OF
3287: # SVBLKS AND IN THE KVNUM FIELD OF KVBLKS. SEE ALSO
3288: # PROCEDURES ASIGN, ACESS AND KWNAM.
3289: #
3290: # UNPROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
3291: #
3292: .set k$abe,0 # abend
3293: .set k$anc,k$abe+cfp$b# anchor
3294: .set k$cas,k$anc+cfp$b# case
3295: .set k$cod,k$cas+cfp$b# code
3296: .set k$dmp,k$cod+cfp$b# dump
3297: .set k$erl,k$dmp+cfp$b# errlimit
3298: .set k$ert,k$erl+cfp$b# errtype
3299: .set k$ftr,k$ert+cfp$b# ftrace
3300: .set k$inp,k$ftr+cfp$b# input
3301: .set k$mxl,k$inp+cfp$b# maxlength
3302: .set k$oup,k$mxl+cfp$b# output
3303: .set k$pfl,k$oup+cfp$b# profile
3304: .set k$tra,k$pfl+cfp$b# trace
3305: .set k$trm,k$tra+cfp$b# trim
3306: #
3307: # PROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
3308: #
3309: .set k$fnc,k$trm+cfp$b# fnclevel
3310: .set k$lst,k$fnc+cfp$b# lastno
3311: .set k$stn,k$lst+cfp$b# stno
3312: #
3313: # KEYWORDS WITH CONSTANT PATTERN VALUES
3314: #
3315: .set k$abo,k$stn+cfp$b# abort
3316: .set k$arb,k$abo+pasi$# arb
3317: .set k$bal,k$arb+pasi$# bal
3318: .set k$fal,k$bal+pasi$# fail
3319: .set k$fen,k$fal+pasi$# fence
3320: .set k$rem,k$fen+pasi$# rem
3321: .set k$suc,k$rem+pasi$# succeed
3322: #page
3323: #
3324: # KEYWORD NUMBER TABLE (CONTINUED)
3325: #
3326: # SPECIAL KEYWORDS
3327: #
3328: .set k$alp,k$suc+1 # alphabet
3329: .set k$rtn,k$alp+1 # rtntype
3330: .set k$stc,k$rtn+1 # stcount
3331: .set k$etx,k$stc+1 # errtext
3332: .set k$stl,k$etx+1 # stlimit
3333: #
3334: # RELATIVE OFFSETS OF SPECIAL KEYWORDS
3335: #
3336: .set k$$al,k$alp-k$alp# alphabet
3337: .set k$$rt,k$rtn-k$alp# rtntype
3338: .set k$$sc,k$stc-k$alp# stcount
3339: .set k$$et,k$etx-k$alp# errtext
3340: .set k$$sl,k$stl-k$alp# stlimit
3341: #
3342: # SYMBOLS USED IN ASIGN AND ACESS PROCEDURES
3343: #
3344: .set k$p$$,k$fnc # first protected keyword
3345: .set k$v$$,k$abo # first keyword with constant value
3346: .set k$s$$,k$alp # first keyword with special acess
3347: #page
3348: #
3349: # FORMAT OF A TABLE BLOCK (TBBLK)
3350: #
3351: # A TABLE BLOCK IS USED TO REPRESENT A TABLE VALUE.
3352: # IT IS BUILT BY A CALL TO THE TABLE OR CONVERT FUNCTIONS.
3353: #
3354: # +------------------------------------+
3355: # I TBTYP I
3356: # +------------------------------------+
3357: # I IDVAL I
3358: # +------------------------------------+
3359: # I TBLEN I
3360: # +------------------------------------+
3361: # +------------------------------------+
3362: # I TBINV I
3363: # +------------------------------------+
3364: # / /
3365: # / TBBUK /
3366: # / /
3367: # +------------------------------------+
3368: #
3369: .set tbtyp,0 # pointer to dummy routine b$tbt
3370: .set tblen,offs2 # length of tbblk in bytes
3371: .set tbinv,offs3 # default initial lookup value
3372: .set tbbuk,tbinv+1 # start of hash bucket pointers
3373: .set tbsi$,tbbuk # size of standard fields in tbblk
3374: .set tbnbk,11 # default no. of buckets
3375: #
3376: # THE TABLE BLOCK IS A HASH TABLE WHICH POINTS TO CHAINS
3377: # OF TABLE ELEMENT BLOCKS REPRESENTING THE ELEMENTS
3378: # IN THE TABLE WHICH HASH INTO THE SAME BUCKET.
3379: #
3380: # TBBUK ENTRIES EITHER POINT TO THE FIRST TEBLK ON THE
3381: # CHAIN OR THEY POINT TO THE TBBLK ITSELF TO INDICATE THE
3382: # END OF THE CHAIN.
3383: #page
3384: #
3385: # TABLE ELEMENT BLOCK (TEBLK)
3386: #
3387: # A TABLE ELEMENT IS USED TO REPRESENT A SINGLE ENTRY IN
3388: # A TABLE (SEE DESCRIPTION OF TBBLK FORMAT FOR HASH TABLE)
3389: #
3390: # +------------------------------------+
3391: # I TETYP I
3392: # +------------------------------------+
3393: # I TESUB I
3394: # +------------------------------------+
3395: # I TEVAL I
3396: # +------------------------------------+
3397: # I TENXT I
3398: # +------------------------------------+
3399: #
3400: .set tetyp,0 # pointer to dummy routine b$tet
3401: .set tesub,tetyp+1 # subscript value
3402: .set teval,tesub+1 # (=vrval) table element value
3403: .set tenxt,teval+1 # link to next teblk
3404: # SEE S$CNV WHERE RELATION IS ASSUMED WITH TENXT AND TBBUK
3405: .set tesi$,tenxt+1 # size of teblk in words
3406: #
3407: # TENXT POINTS TO THE NEXT TEBLK ON THE HASH CHAIN FROM THE
3408: # TBBUK CHAIN FOR THIS HASH INDEX. AT THE END OF THE CHAIN,
3409: # TENXT POINTS BACK TO THE START OF THE TBBLK.
3410: #
3411: # TEVAL CONTAINS A DATA POINTER OR A TRBLK POINTER.
3412: #
3413: # TESUB CONTAINS A DATA POINTER.
3414: #page
3415: #
3416: # TRAP BLOCK (TRBLK)
3417: #
3418: # A TRAP BLOCK IS USED TO REPRESENT A TRACE OR INPUT OR
3419: # OUTPUT ASSOCIATION IN RESPONSE TO A CALL TO THE TRACE
3420: # INPUT OR OUTPUT SYSTEM FUNCTIONS. SEE BELOW FOR DETAILS
3421: #
3422: # +------------------------------------+
3423: # I TRIDN I
3424: # +------------------------------------+
3425: # I TRTYP I
3426: # +------------------------------------+
3427: # I TRVAL OR TRLBL OR TRNXT OR TRKVR I
3428: # +------------------------------------+
3429: # I TRTAG OR TRTER OR TRTRF I
3430: # +------------------------------------+
3431: # I TRFNC OR TRFPT I
3432: # +------------------------------------+
3433: #
3434: .set tridn,0 # pointer to dummy routine b$trt
3435: .set trtyp,tridn+1 # trap type code
3436: .set trval,trtyp+1 # value of trapped variable (=vrval)
3437: .set trnxt,trval # ptr to next trblk on trblk chain
3438: .set trlbl,trval # ptr to actual label (traced label)
3439: .set trkvr,trval # vrblk pointer for keyword trace
3440: .set trtag,trval+1 # trace tag
3441: .set trter,trtag # ptr to terminal vrblk or null
3442: .set trtrf,trtag # ptr to trblk holding fcblk ptr
3443: .set trfnc,trtag+1 # trace function vrblk (zero if none)
3444: .set trfpt,trfnc # fcblk ptr for sysio
3445: .set trsi$,trfnc+1 # number of words in trblk
3446: #
3447: .set trtin,0 # trace type for input association
3448: .set trtac,trtin+1 # trace type for access trace
3449: .set trtvl,trtac+1 # trace type for value trace
3450: .set trtou,trtvl+1 # trace type for output association
3451: .set trtfc,trtou+1 # trace type for fcblk identification
3452: #page
3453: #
3454: # TRAP BLOCK (CONTINUED)
3455: #
3456: # VARIABLE INPUT ASSOCIATION
3457: #
3458: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3459: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3460: # OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3461: # CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3462: #
3463: # TRTYP IS SET TO TRTIN
3464: # TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3465: # TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS
3466: # FOR INPUT, TERMINAL, ELSE IT IS NULL.
3467: # TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS
3468: # TO AN FCBLK USED FOR I/O ASSOCIATION.
3469: # TRFPT IS THE FCBLK PTR RETURNED BY SYSIO.
3470: #
3471: # VARIABLE ACCESS TRACE ASSOCIATION
3472: #
3473: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3474: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3475: # OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3476: # CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3477: #
3478: # TRTYP IS SET TO TRTAC
3479: # TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3480: # TRTAG IS THE TRACE TAG (0 IF NONE)
3481: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3482: #
3483: # VARIABLE VALUE TRACE ASSOCIATION
3484: #
3485: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3486: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3487: # OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3488: # CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3489: #
3490: # TRTYP IS SET TO TRTVL
3491: # TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3492: # TRTAG IS THE TRACE TAG (0 IF NONE)
3493: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3494: #page
3495: # TRAP BLOCK (CONTINUED)
3496: #
3497: # VARIABLE OUTPUT ASSOCIATION
3498: #
3499: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3500: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3501: # OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3502: # CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3503: #
3504: # TRTYP IS SET TO TRTOU
3505: # TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3506: # TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS
3507: # FOR OUTPUT, TERMINAL, ELSE IT IS NULL.
3508: # TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS
3509: # TO AN FCBLK USED FOR I/O ASSOCIATION.
3510: # TRFPT IS THE FCBLK PTR RETURNED BY SYSIO.
3511: #
3512: # FUNCTION CALL TRACE
3513: #
3514: # THE PFCTR FIELD OF THE CORRESPONDING PFBLK IS SET
3515: # TO POINT TO A TRBLK.
3516: #
3517: # TRTYP IS SET TO TRTIN
3518: # TRNXT IS ZERO
3519: # TRTAG IS THE TRACE TAG (0 IF NONE)
3520: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3521: #
3522: # FUNCTION RETURN TRACE
3523: #
3524: # THE PFRTR FIELD OF THE CORRESPONDING PFBLK IS SET
3525: # TO POINT TO A TRBLK
3526: #
3527: # TRTYP IS SET TO TRTIN
3528: # TRNXT IS ZERO
3529: # TRTAG IS THE TRACE TAG (0 IF NONE)
3530: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3531: #
3532: # LABEL TRACE
3533: #
3534: # THE VRLBL OF THE VRBLK FOR THE LABEL IS
3535: # CHANGED TO POINT TO A TRBLK AND THE VRTRA FIELD IS
3536: # SET TO B$VRT TO ACTIVATE THE CHECK.
3537: #
3538: # TRTYP IS SET TO TRTIN
3539: # TRLBL POINTS TO THE ACTUAL LABEL (CDBLK) VALUE
3540: # TRTAG IS THE TRACE TAG (0 IF NONE)
3541: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3542: #page
3543: #
3544: # TRAP BLOCK (CONTINUED)
3545: #
3546: # KEYWORD TRACE
3547: #
3548: # KEYWORDS WHICH CAN BE TRACED POSSESS A UNIQUE
3549: # LOCATION WHICH IS ZERO IF THERE IS NO TRACE AND
3550: # POINTS TO A TRBLK IF THERE IS A TRACE. THE LOCATIONS
3551: # ARE AS FOLLOWS.
3552: #
3553: # R$ERT ERRTYPE
3554: # R$FNC FNCLEVEL
3555: # R$STC STCOUNT
3556: #
3557: # THE FORMAT OF THE TRBLK IS AS FOLLOWS.
3558: #
3559: # TRTYP IS SET TO TRTIN
3560: # TRKVR IS A POINTER TO THE VRBLK FOR THE KEYWORD
3561: # TRTAG IS THE TRACE TAG (0 IF NONE)
3562: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3563: #
3564: # INPUT/OUTPUT FILE ARG1 TRAP BLOCK
3565: #
3566: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3567: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE OF
3568: # A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3569: # CONTAIN =B$VRA AND =B$VRV. THIS TRAP BLOCK IS USED
3570: # TO HOLD A POINTER TO THE FCBLK WHICH AN
3571: # IMPLEMENTATION MAY REQUEST TO HOLD INFORMATION
3572: # ABOUT A FILE.
3573: #
3574: # TRTYP IS SET TO TRTFC
3575: # TRNEXT POINTS TO NEXT TRBLK OR TRVAL IS VARIABLE VAL
3576: # TRFNM IS 0
3577: # TRFPT IS THE FCBLK POINTER.
3578: #
3579: # NOTE THAT WHEN MULTIPLE TRAPS ARE SET ON A VARIABLE
3580: # THE ORDER IS IN ASCENDING VALUE OF TRTYP FIELD.
3581: #
3582: # INPUT ASSOCIATION (IF PRESENT)
3583: # ACCESS TRACE (IF PRESENT)
3584: # VALUE TRACE (IF PRESENT)
3585: # OUTPUT ASSOCIATION (IF PRESENT)
3586: #
3587: # THE ACTUAL VALUE OF THE VARIABLE IS STORED IN THE TRVAL
3588: # FIELD OF THE LAST TRBLK ON THE CHAIN.
3589: #
3590: # THIS IMPLEMENTATION DOES NOT PERMIT TRACE OR I/O
3591: # ASSOCIATIONS TO ANY OF THE PSEUDO-VARIABLES.
3592: #page
3593: #
3594: # VECTOR BLOCK (VCBLK)
3595: #
3596: # A VCBLK IS USED TO REPRESENT AN ARRAY VALUE WHICH HAS
3597: # ONE DIMENSION WHOSE LOWER BOUND IS ONE. ALL OTHER ARRAYS
3598: # ARE REPRESENTED BY ARBLKS. A VCBLK IS CREATED BY THE
3599: # SYSTEM FUNCTION ARRAY (S$ARR) WHEN PASSED AN INTEGER ARG.
3600: #
3601: # +------------------------------------+
3602: # I VCTYP I
3603: # +------------------------------------+
3604: # I IDVAL I
3605: # +------------------------------------+
3606: # I VCLEN I
3607: # +------------------------------------+
3608: # I VCVLS I
3609: # +------------------------------------+
3610: #
3611: .set vctyp,0 # pointer to dummy routine b$vct
3612: .set vclen,offs2 # length of vcblk in bytes
3613: .set vcvls,offs3 # start of vector values
3614: .set vcsi$,vcvls # size of standard fields in vcblk
3615: .set vcvlb,vcvls-1 # offset one word behind vcvls
3616: .set vctbd,tbsi$-vcsi$# difference in sizes - see prtvl
3617: #
3618: # VCVLS ARE EITHER DATA POINTERS OR TRBLK POINTERS
3619: #
3620: # THE DIMENSION CAN BE DEDUCED FROM VCLEN.
3621: #page
3622: #
3623: # VARIABLE BLOCK (VRBLK)
3624: #
3625: # A VARIABLE BLOCK IS BUILT IN THE STATIC MEMORY AREA
3626: # FOR EVERY VARIABLE REFERENCED OR CREATED BY A PROGRAM.
3627: #
3628: # NOTE THAT SINCE THESE BLOCKS ONLY OCCUR IN THE STATIC
3629: # REGION, IT IS PERMISSIBLE TO POINT TO ANY WORD IN
3630: # THE BLOCK AND THIS IS USED TO PROVIDE THREE DISTINCT
3631: # ACCESS POINTS FROM THE GENERATED CODE AS FOLLOWS.
3632: #
3633: # 1) POINT TO VRGET (FIRST WORD OF VRBLK) TO LOAD THE
3634: # VALUE OF THE VARIABLE ONTO THE MAIN STACK.
3635: #
3636: # 2) POINT TO VRSTO (SECOND WORD OF VRBLK) TO STORE THE
3637: # TOP STACK ELEMENT AS THE VALUE OF THE VARIABLE.
3638: #
3639: # 3) POINT TO VRTRA (FOURTH WORD OF VRBLK) TO JUMP TO
3640: # THE LABEL ASSOCIATED WITH THE VARIABLE NAME.
3641: #
3642: # +------------------------------------+
3643: # I VRGET I
3644: # +------------------------------------+
3645: # I VRSTO I
3646: # +------------------------------------+
3647: # I VRVAL I
3648: # +------------------------------------+
3649: # I VRTRA I
3650: # +------------------------------------+
3651: # I VRLBL I
3652: # +------------------------------------+
3653: # I VRFNC I
3654: # +------------------------------------+
3655: # I VRNXT I
3656: # +------------------------------------+
3657: # I VRLEN I
3658: # +------------------------------------+
3659: # / /
3660: # / VRCHS = VRSVP /
3661: # / /
3662: # +------------------------------------+
3663: #page
3664: #
3665: # VARIABLE BLOCK (CONTINUED)
3666: #
3667: .set vrget,0 # pointer to routine to load value
3668: .set vrsto,vrget+1 # pointer to routine to store value
3669: .set vrval,vrsto+1 # variable value
3670: .set vrvlo,vrval-vrsto# offset to value from store field
3671: .set vrtra,vrval+1 # pointer to routine to jump to label
3672: .set vrlbl,vrtra+1 # pointer to code for label
3673: .set vrlbo,vrlbl-vrtra# offset to label from transfer field
3674: .set vrfnc,vrlbl+1 # pointer to function block
3675: .set vrnxt,vrfnc+1 # pointer to next vrblk on hash chain
3676: .set vrlen,vrnxt+1 # length of name (or zero)
3677: .set vrchs,vrlen+1 # characters of name (vrlen gt 0)
3678: .set vrsvp,vrlen+1 # ptr to svblk (vrlen eq 0)
3679: .set vrsi$,vrchs+1 # number of standard fields in vrblk
3680: .set vrsof,vrlen-sclen# offset to dummy scblk for name
3681: .set vrsvo,vrsvp-vrsof# pseudo-offset to vrsvp field
3682: #
3683: # VRGET = B$VRL IF NOT INPUT ASSOCIATED OR ACCESS TRACED
3684: # VRGET = B$VRA IF INPUT ASSOCIATED OR ACCESS TRACED
3685: #
3686: # VRSTO = B$VRS IF NOT OUTPUT ASSOCIATED OR VALUE TRACED
3687: # VRSTO = B$VRV IF OUTPUT ASSOCIATED OR VALUE TRACED
3688: # VRSTO = B$VRE IF VALUE IS PROTECTED PATTERN VALUE
3689: #
3690: # VRVAL POINTS TO THE APPROPRIATE VALUE UNLESS THE
3691: # VARIABLE IS I/O/TRACE ASSOCIATED IN WHICH CASE, VRVAL
3692: # POINTS TO AN APPROPRIATE TRBLK (TRAP BLOCK) CHAIN.
3693: #
3694: # VRTRA = B$VRG IF THE LABEL IS NOT TRACED
3695: # VRTRA = B$VRT IF THE LABEL IS TRACED
3696: #
3697: # VRLBL POINTS TO A CDBLK IF THERE IS A LABEL
3698: # VRLBL POINTS TO THE SVBLK SVLBL FIELD FOR A SYSTEM LABEL
3699: # VRLBL POINTS TO STNDL FOR AN UNDEFINED LABEL
3700: # VRLBL POINTS TO A TRBLK IF THE LABEL IS TRACED
3701: #
3702: # VRFNC POINTS TO A FFBLK FOR A FIELD FUNCTION
3703: # VRFNC POINTS TO A DFBLK FOR A DATATYPE FUNCTION
3704: # VRFNC POINTS TO A PFBLK FOR A PROGRAM DEFINED FUNCTION
3705: # VRFNC POINTS TO A EFBLK FOR AN EXTERNAL LOADED FUNCTION
3706: # VRFNC POINTS TO SVFNC (SVBLK) FOR A SYSTEM FUNCTION
3707: # VRFNC POINTS TO STNDF IF THE FUNCTION IS UNDEFINED
3708: #
3709: # VRNXT POINTS TO THE NEXT VRBLK ON THIS CHAIN UNLESS
3710: # THIS IS THE END OF THE CHAIN IN WHICH CASE IT IS ZERO.
3711: #
3712: # VRLEN IS THE NAME LENGTH FOR A NON-SYSTEM VARIABLE.
3713: # VRLEN IS ZERO FOR A SYSTEM VARIABLE.
3714: #
3715: # VRCHS IS THE NAME (LJRZ) IF VRLEN IS NON-ZERO.
3716: # VRSVP IS A PTR TO THE SVBLK IF VRLEN IS ZERO.
3717: #page
3718: #
3719: # FORMAT OF A NON-RELOCATABLE EXTERNAL BLOCK (XNBLK)
3720: #
3721: # AN XNBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL)
3722: # DATA VALUE. THE BLOCK CONTAINS NO POINTERS TO OTHER
3723: # RELOCATABLE BLOCKS. AN XNBLK IS USED BY EXTERNAL FUNCTION
3724: # PROCESSING OR POSSIBLY FOR SYSTEM I/O ROUTINES ETC.
3725: # THE MACRO-SYSTEM ITSELF DOES NOT USE XNBLKS.
3726: # THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK.
3727: # SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS.
3728: #
3729: # +------------------------------------+
3730: # I XNTYP I
3731: # +------------------------------------+
3732: # I XNLEN I
3733: # +------------------------------------+
3734: # / /
3735: # / XNDTA /
3736: # / /
3737: # +------------------------------------+
3738: #
3739: .set xntyp,0 # pointer to dummy routine b$xnt
3740: .set xnlen,xntyp+1 # length of xnblk in bytes
3741: .set xndta,xnlen+1 # data words
3742: .set xnsi$,xndta # size of standard fields in xnblk
3743: #
3744: # NOTE THAT THE TERM NON-RELOCATABLE REFERS TO THE CONTENTS
3745: # AND NOT THE BLOCK ITSELF. AN XNBLK CAN BE MOVED AROUND IF
3746: # IT IS BUILT IN THE DYNAMIC MEMORY AREA.
3747: #page
3748: #
3749: # RELOCATABLE EXTERNAL BLOCK (XRBLK)
3750: #
3751: # AN XRBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL)
3752: # DATA VALUE. THE DATA AREA IN THIS BLOCK CONSISTS ONLY
3753: # OF ADDRESS VALUES AND ANY ADDRESSES POINTING INTO THE
3754: # DYNAMIC MEMORY AREA MUST POINT TO THE START OF OTHER
3755: # DATA BLOCKS. SEE ALSO DESCRIPTION OF XNBLK.
3756: # THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK.
3757: # SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS.
3758: #
3759: # +------------------------------------+
3760: # I XRTYP I
3761: # +------------------------------------+
3762: # I XRLEN I
3763: # +------------------------------------+
3764: # / /
3765: # / XRPTR /
3766: # / /
3767: # +------------------------------------+
3768: #
3769: .set xrtyp,0 # pointer to dummy routine b$xrt
3770: .set xrlen,xrtyp+1 # length of xrblk in bytes
3771: .set xrptr,xrlen+1 # start of address pointers
3772: .set xrsi$,xrptr # size of standard fields in xrblk
3773: #page
3774: #
3775: # S$CNV (CONVERT) FUNCTION SWITCH CONSTANTS. THE VALUES
3776: # ARE TIED TO THE ORDER OF THE ENTRIES IN THE SVCTB TABLE
3777: # AND HENCE TO THE BRANCH TABLE IN S$CNV.
3778: #
3779: .set cnvst,8 # max standard type code for convert
3780: .set cnvrt,cnvst+1 # convert code for reals
3781: .set cnvbt,cnvrt+1 # convert code for buffer
3782: .set cnvtt,cnvbt+1 # bsw code for convert
3783: #
3784: # INPUT IMAGE LENGTH
3785: #
3786: .set iniln,132 # default image length for compiler
3787: .set inils,80 # image length if -sequ in effect
3788: #
3789: .set ionmb,2 # name base used for iochn in sysio
3790: .set ionmo,4 # name offset used for iochn in sysio
3791: #
3792: # IN GENERAL, MEANINGFUL MNEMONICS SHOULD BE USED FOR
3793: # OFFSETS. HOWEVER FOR SMALL INTEGERS USED OFTEN IN
3794: # LITERALS THE FOLLOWING GENERAL DEFINITIONS ARE PROVIDED.
3795: #
3796: .set num01,1
3797: .set num02,2
3798: .set num03,3
3799: .set num04,4
3800: .set num05,5
3801: .set num06,6
3802: .set num07,7
3803: .set num08,8
3804: .set num09,9
3805: .set num10,10
3806: .set nini8,998
3807: .set nini9,999
3808: .set thsnd,1000
3809: #page
3810: #
3811: # NUMBERS OF UNDEFINED SPITBOL OPERATORS
3812: #
3813: .set opbun,5 # no. of binary undefined ops
3814: .set opuun,6 # no of unary undefined ops
3815: #
3816: # OFFSETS USED IN PRTSN, PRTMI AND ACESS
3817: #
3818: .set prsnf,13 # offset used in prtsn
3819: .set prtmf,15 # offset to col 15 (prtmi)
3820: .set rilen,120 # buffer length for sysri
3821: #
3822: # CODES FOR STAGES OF PROCESSING
3823: #
3824: .set stgic,0 # initial compile
3825: .set stgxc,stgic+1 # execution compile (code)
3826: .set stgev,stgxc+1 # expression eval during execution
3827: .set stgxt,stgev+1 # execution time
3828: .set stgce,stgxt+1 # initial compile after end line
3829: .set stgxe,stgce+1 # exec. compile after end line
3830: .set stgnd,stgce-stgic# difference in stage after end
3831: .set stgee,stgxe+1 # eval evaluating expression
3832: .set stgno,stgee+1 # number of codes
3833: #page
3834: #
3835: #
3836: # STATEMENT NUMBER PAD COUNT FOR LISTR
3837: #
3838: .set stnpd,8 # statement no. pad count
3839: #
3840: # SYNTAX TYPE CODES
3841: #
3842: # THESE CODES ARE RETURNED FROM THE SCANE PROCEDURE.
3843: #
3844: # THEY ARE SPACED 3 APART FOR THE BENEFIT OF EXPAN.
3845: #
3846: .set t$uop,0 # unary operator
3847: .set t$lpr,t$uop+3 # left paren
3848: .set t$lbr,t$lpr+3 # left bracket
3849: .set t$cma,t$lbr+3 # comma
3850: .set t$fnc,t$cma+3 # function call
3851: .set t$var,t$fnc+3 # variable
3852: .set t$con,t$var+3 # constant
3853: .set t$bop,t$con+3 # binary operator
3854: .set t$rpr,t$bop+3 # right paren
3855: .set t$rbr,t$rpr+3 # right bracket
3856: .set t$col,t$rbr+3 # colon
3857: .set t$smc,t$col+3 # semi-colon
3858: #
3859: # THE FOLLOWING DEFINITIONS ARE USED ONLY IN THE GOTO FIELD
3860: #
3861: .set t$fgo,t$smc+1 # failure goto
3862: .set t$sgo,t$fgo+1 # success goto
3863: #
3864: # THE ABOVE CODES ARE GROUPED SO THAT CODES FOR ELEMENTS
3865: # WHICH CAN LEGITIMATELY IMMEDIATELY PRECEDE A UNARY
3866: # OPERATOR COME FIRST TO FACILITATE OPERATOR SYNTAX CHECK.
3867: #
3868: .set t$uok,t$fnc # last code ok before unary operator
3869: #page
3870: #
3871: # DEFINITIONS OF VALUES FOR EXPAN JUMP TABLE
3872: #
3873: .set t$uo0,t$uop+0 # unary operator, state zero
3874: .set t$uo1,t$uop+1 # unary operator, state one
3875: .set t$uo2,t$uop+2 # unary operator, state two
3876: .set t$lp0,t$lpr+0 # left paren, state zero
3877: .set t$lp1,t$lpr+1 # left paren, state one
3878: .set t$lp2,t$lpr+2 # left paren, state two
3879: .set t$lb0,t$lbr+0 # left bracket, state zero
3880: .set t$lb1,t$lbr+1 # left bracket, state one
3881: .set t$lb2,t$lbr+2 # left bracket, state two
3882: .set t$cm0,t$cma+0 # comma, state zero
3883: .set t$cm1,t$cma+1 # comma, state one
3884: .set t$cm2,t$cma+2 # comma, state two
3885: .set t$fn0,t$fnc+0 # function call, state zero
3886: .set t$fn1,t$fnc+1 # function call, state one
3887: .set t$fn2,t$fnc+2 # function call, state two
3888: .set t$va0,t$var+0 # variable, state zero
3889: .set t$va1,t$var+1 # variable, state one
3890: .set t$va2,t$var+2 # variable, state two
3891: .set t$co0,t$con+0 # constant, state zero
3892: .set t$co1,t$con+1 # constant, state one
3893: .set t$co2,t$con+2 # constant, state two
3894: .set t$bo0,t$bop+0 # binary operator, state zero
3895: .set t$bo1,t$bop+1 # binary operator, state one
3896: .set t$bo2,t$bop+2 # binary operator, state two
3897: .set t$rp0,t$rpr+0 # right paren, state zero
3898: .set t$rp1,t$rpr+1 # right paren, state one
3899: .set t$rp2,t$rpr+2 # right paren, state two
3900: .set t$rb0,t$rbr+0 # right bracket, state zero
3901: .set t$rb1,t$rbr+1 # right bracket, state one
3902: .set t$rb2,t$rbr+2 # right bracket, state two
3903: .set t$cl0,t$col+0 # colon, state zero
3904: .set t$cl1,t$col+1 # colon, state one
3905: .set t$cl2,t$col+2 # colon, state two
3906: .set t$sm0,t$smc+0 # semicolon, state zero
3907: .set t$sm1,t$smc+1 # semicolon, state one
3908: .set t$sm2,t$smc+2 # semicolon, state two
3909: #
3910: .set t$nes,t$sm2+1 # number of entries in branch table
3911: #page
3912: #
3913: # DEFINITION OF OFFSETS USED IN CONTROL CARD PROCESSING
3914: #
3915: .set cc$ca,0 # -case
3916: .set cc$do,cc$ca+1 # -double
3917: .set cc$du,cc$do+1 # -dump
3918: .set cc$ej,cc$du+1 # -eject
3919: .set cc$er,cc$ej+1 # -errors
3920: .set cc$ex,cc$er+1 # -execute
3921: .set cc$fa,cc$ex+1 # -fail
3922: .set cc$li,cc$fa+1 # -list
3923: .set cc$nr,cc$li+1 # -noerrors
3924: .set cc$nx,cc$nr+1 # -noexecute
3925: .set cc$nf,cc$nx+1 # -nofail
3926: .set cc$nl,cc$nf+1 # -nolist
3927: .set cc$no,cc$nl+1 # -noopt
3928: .set cc$np,cc$no+1 # -noprint
3929: .set cc$op,cc$np+1 # -optimise
3930: .set cc$pr,cc$op+1 # -print
3931: .set cc$si,cc$pr+1 # -single
3932: .set cc$sp,cc$si+1 # -space
3933: .set cc$st,cc$sp+1 # -stitl
3934: .set cc$ti,cc$st+1 # -title
3935: .set cc$tr,cc$ti+1 # -trace
3936: .set cc$nc,cc$tr+1 # number of control cards
3937: .set ccnoc,4 # no. of chars included in match
3938: .set ccofs,7 # offset to start of title/subtitle
3939: #page
3940: #
3941: # DEFINITIONS OF STACK OFFSETS USED IN CMPIL PROCEDURE
3942: #
3943: # SEE DESCRIPTION AT START OF CMPIL PROCEDURE FOR DETAILS
3944: # OF USE OF THESE LOCATIONS ON THE STACK.
3945: #
3946: .set cmstm,0 # tree for statement body
3947: .set cmsgo,cmstm+1 # tree for success goto
3948: .set cmfgo,cmsgo+1 # tree for fail goto
3949: .set cmcgo,cmfgo+1 # conditional goto flag
3950: .set cmpcd,cmcgo+1 # previous cdblk pointer
3951: .set cmffp,cmpcd+1 # failure fill in flag for previous
3952: .set cmffc,cmffp+1 # failure fill in flag for current
3953: .set cmsop,cmffc+1 # success fill in offset for previous
3954: .set cmsoc,cmsop+1 # success fill in offset for current
3955: .set cmlbl,cmsoc+1 # ptr to vrblk for current label
3956: .set cmtra,cmlbl+1 # ptr to entry cdblk
3957: #
3958: .set cmnen,cmtra+1 # count of stack entries for cmpil
3959: #
3960: # A FEW CONSTANTS USED BY THE PROFILER
3961: .set pfpd1,8 # pad positions ...
3962: .set pfpd2,20 # ... for profile ...
3963: .set pfpd3,32 # ... printout
3964: .set pf$i2,cfp$i+cfp$i# size of table entry (2 ints)
3965: #
3966: #title s p i t b o l -- constant section
3967: #
3968: # THIS SECTION CONSISTS ENTIRELY OF ASSEMBLED CONSTANTS.
3969: #
3970: # ALL LABEL NAMES ARE FIVE LETTERS. THE ORDER IS
3971: # APPROXIMATELY ALPHABETICAL, BUT IN SOME CASES (ALWAYS
3972: # DOCUMENTED), CONSTANTS MUST BE PLACED IN SOME SPECIAL
3973: # ORDER WHICH MUST NOT BE DISTURBED.
3974: #
3975: # IT MUST ALSO BE REMEMBERED THAT THERE IS A REQUIREMENT
3976: # FOR NO FORWARD REFERENCES WHICH ALSO DISTURBS THE
3977: # ALPHABETICAL ORDER IN SOME CASES.
3978: #
3979: .data 0
3980: #sec # start of constant section
3981: #
3982: # FREE STORE PERCENTAGE (USED BY ALLOC)
3983: #
3984: alfsp: .long e$fsp # free store percentage
3985: #
3986: # BIT CONSTANTS FOR GENERAL USE
3987: #
3988: bits0: .long 0 # all zero bits
3989: bits1: .long 1 # one bit in low order position
3990: bits2: .long 2 # bit in position 2
3991: bits3: .long 4 # bit in position 3
3992: bits4: .long 8 # bit in position 4
3993: bits5: .long 16 # bit in position 5
3994: bits6: .long 32 # bit in position 6
3995: bits7: .long 64 # bit in position 7
3996: bits8: .long 128 # bit in position 8
3997: bits9: .long 256 # bit in position 9
3998: bit10: .long 512 # bit in position 10
3999: bitsm: .long cfp$m # mask for max integer
4000: #
4001: # BIT CONSTANTS FOR SVBLK (SVBIT FIELD) TESTS
4002: #
4003: btfnc: .long svfnc # bit to test for function
4004: btknm: .long svknm # bit to test for keyword number
4005: btlbl: .long svlbl # bit to test for label
4006: btffc: .long svffc # bit to test for fast call
4007: btckw: .long svckw # bit to test for constant keyword
4008: btprd: .long svprd # bit to test for predicate function
4009: btpre: .long svpre # bit to test for preevaluation
4010: btval: .long svval # bit to test for value
4011: #page
4012: #
4013: # LIST OF NAMES USED FOR CONTROL CARD PROCESSING
4014: #
4015: ccnms: .ascii "CASE"
4016: .align 2
4017: .ascii "DOUB"
4018: .align 2
4019: .ascii "DUMP"
4020: .align 2
4021: .ascii "EJEC"
4022: .align 2
4023: .ascii "ERRO"
4024: .align 2
4025: .ascii "EXEC"
4026: .align 2
4027: .ascii "FAIL"
4028: .align 2
4029: .ascii "LIST"
4030: .align 2
4031: .ascii "NOER"
4032: .align 2
4033: .ascii "NOEX"
4034: .align 2
4035: .ascii "NOFA"
4036: .align 2
4037: .ascii "NOLI"
4038: .align 2
4039: .ascii "NOOP"
4040: .align 2
4041: .ascii "NOPR"
4042: .align 2
4043: .ascii "OPTI"
4044: .align 2
4045: .ascii "PRIN"
4046: .align 2
4047: .ascii "SING"
4048: .align 2
4049: .ascii "SPAC"
4050: .align 2
4051: .ascii "STIT"
4052: .align 2
4053: .ascii "TITL"
4054: .align 2
4055: .ascii "TRAC"
4056: .align 2
4057: #
4058: # HEADER MESSAGES FOR DUMPR PROCEDURE (SCBLK FORMAT)
4059: #
4060: dmhdk: .long b$scl # dump of keyword values
4061: .long 22
4062: .ascii "DUMP OF KEYWORD VALUES"
4063: .align 2
4064: #
4065: dmhdv: .long b$scl # dump of natural variables
4066: .long 25
4067: .ascii "DUMP OF NATURAL VARIABLES"
4068: .align 2
4069: #page
4070: #
4071: # MESSAGE TEXT FOR COMPILATION STATISTICS
4072: #
4073: encm1: .long b$scl
4074: .long 10
4075: .ascii "STORE USED"
4076: .align 2
4077: #
4078: encm2: .long b$scl
4079: .long 10
4080: .ascii "STORE LEFT"
4081: .align 2
4082: #
4083: encm3: .long b$scl
4084: .long 11
4085: .ascii "COMP ERRORS"
4086: .align 2
4087: #
4088: encm4: .long b$scl
4089: .long 14
4090: .ascii "COMP TIME-MSEC"
4091: .align 2
4092: #
4093: encm5: .long b$scl # execution suppressed
4094: .long 20
4095: .ascii "EXECUTION SUPPRESSED"
4096: .align 2
4097: #
4098: # STRING CONSTANT FOR ABNORMAL END
4099: #
4100: endab: .long b$scl
4101: .long 12
4102: .ascii "ABNORMAL END"
4103: .align 2
4104: #page
4105: #
4106: # MEMORY OVERFLOW DURING INITIALISATION
4107: #
4108: endmo: .long b$scl
4109: endml: .long 15
4110: .ascii "MEMORY OVERFLOW"
4111: .align 2
4112: #
4113: # STRING CONSTANT FOR MESSAGE ISSUED BY L$END
4114: #
4115: endms: .long b$scl
4116: .long 10
4117: .ascii "NORMAL END"
4118: .align 2
4119: #
4120: # FAIL MESSAGE FOR STACK FAIL SECTION
4121: #
4122: endso: .long b$scl # stack overflow in garbage collector
4123: .long 36
4124: .ascii "STACK OVERFLOW IN GARBAGE COLLECTION"
4125: .align 2
4126: #
4127: # STRING CONSTANT FOR TIME UP
4128: #
4129: endtu: .long b$scl
4130: .long 15
4131: .ascii "ERROR - TIME UP"
4132: .align 2
4133: #page
4134: #
4135: # STRING CONSTANT FOR ERROR MESSAGE (ERROR SECTION)
4136: #
4137: ermms: .long b$scl # error
4138: .long 5
4139: .ascii "ERROR"
4140: .align 2
4141: #
4142: ermns: .long b$scl # string / -- /
4143: .long 4
4144: .ascii " -- "
4145: .align 2
4146: #
4147: # STRING CONSTANT FOR PAGE NUMBERING
4148: #
4149: lstms: .long b$scl # page
4150: .long 5
4151: .ascii "PAGE "
4152: .align 2
4153: #
4154: # LISTING HEADER MESSAGE
4155: #
4156: headr: .long b$scl
4157: .long 25
4158: .ascii "MACRO SPITBOL VERSION 3.5"
4159: .align 2
4160: #
4161: headv: .long b$scl # for exit() version no. check
4162: .long 3
4163: .ascii "3.5"
4164: .align 2
4165: #
4166: # INTEGER CONSTANTS FOR GENERAL USE
4167: # ICBLD OPTIMISATION USES THE FIRST THREE.
4168: #
4169: int$r: .long b$icl
4170: intv0: .long 0 # 0
4171: inton: .long b$icl
4172: intv1: .long 1 # 1
4173: inttw: .long b$icl
4174: intv2: .long 2 # 2
4175: intvt: .long 10 # 10
4176: intvh: .long 100 # 100
4177: intth: .long 1000 # 1000
4178: #
4179: # TABLE USED IN ICBLD OPTIMISATION
4180: #
4181: intab: .long int$r # pointer to 0
4182: .long inton # pointer to 1
4183: .long inttw # pointer to 2
4184: #page
4185: #
4186: # SPECIAL PATTERN NODES. THE FOLLOWING PATTERN NODES
4187: # CONSIST SIMPLY OF A PCODE POINTER, SEE MATCH ROUTINES
4188: # (P$XXX) FOR FULL DETAILS OF THEIR USE AND FORMAT).
4189: #
4190: ndabb: .long p$abb # arbno
4191: ndabd: .long p$abd # arbno
4192: ndarc: .long p$arc # arb
4193: ndexb: .long p$exb # expression
4194: ndfnb: .long p$fnb # fence()
4195: ndfnd: .long p$fnd # fence()
4196: ndexc: .long p$exc # expression
4197: ndimb: .long p$imb # immediate assignment
4198: ndimd: .long p$imd # immediate assignment
4199: ndnth: .long p$nth # pattern end (null pattern)
4200: ndpab: .long p$pab # pattern assignment
4201: ndpad: .long p$pad # pattern assignment
4202: nduna: .long p$una # anchor point movement
4203: #
4204: # KEYWORD CONSTANT PATTERN NODES. THE FOLLOWING NODES ARE
4205: # USED AS THE VALUES OF PATTERN KEYWORDS AND THE INITIAL
4206: # VALUES OF THE CORRESPONDING NATURAL VARIABLES. ALL
4207: # NODES ARE IN P0BLK FORMAT AND THE ORDER IS TIED TO THE
4208: # DEFINITIONS OF CORRESPONDING K$XXX SYMBOLS.
4209: #
4210: ndabo: .long p$abo # abort
4211: .long ndnth
4212: ndarb: .long p$arb # arb
4213: .long ndnth
4214: ndbal: .long p$bal # bal
4215: .long ndnth
4216: ndfal: .long p$fal # fail
4217: .long ndnth
4218: ndfen: .long p$fen # fence
4219: .long ndnth
4220: ndrem: .long p$rem # rem
4221: .long ndnth
4222: ndsuc: .long p$suc # succeed
4223: .long ndnth
4224: #
4225: # NULL STRING. ALL NULL VALUES POINT TO THIS STRING. THE
4226: # SVCHS FIELD CONTAINS A BLANK TO PROVIDE FOR EASY DEFAULT
4227: # PROCESSING IN TRACE, STOPTR, LPAD AND RPAD.
4228: # NULLW CONTAINS 10 BLANKS WHICH ENSURES AN ALL BLANK WORD
4229: # BUT FOR VERY EXCEPTIONAL MACHINES.
4230: #
4231: nulls: .long b$scl # null string value
4232: .long 0 # sclen = 0
4233: nullw: .ascii " "
4234: .align 2
4235: #page
4236: #
4237: # OPERATOR DOPE VECTORS (SEE DVBLK FORMAT)
4238: #
4239: opdvc: .long o$cnc # concatenation
4240: .long c$cnc
4241: .long llcnc
4242: .long rrcnc
4243: #
4244: # OPDVS IS USED WHEN SCANNING BELOW THE TOP LEVEL TO
4245: # INSURE THAT THE CONCATENATION WILL NOT BE LATER
4246: # MISTAKEN FOR PATTERN MATCHING
4247: #
4248: opdvp: .long o$cnc # concatenation - not pattern match
4249: .long c$cnp
4250: .long llcnc
4251: .long rrcnc
4252: #
4253: # NOTE THAT THE ORDER OF THE REMAINING ENTRIES IS TIED TO
4254: # THE ORDER OF THE CODING IN THE SCANE PROCEDURE.
4255: #
4256: opdvs: .long o$ass # assignment
4257: .long c$ass
4258: .long llass
4259: .long rrass
4260: #
4261: .long 6 # unary equal
4262: .long c$uuo
4263: .long lluno
4264: #
4265: .long o$pmv # pattern match
4266: .long c$pmt
4267: .long llpmt
4268: .long rrpmt
4269: #
4270: .long o$int # interrogation
4271: .long c$uvl
4272: .long lluno
4273: #
4274: .long 1 # binary ampersand
4275: .long c$ubo
4276: .long llamp
4277: .long rramp
4278: #
4279: .long o$kwv # keyword reference
4280: .long c$key
4281: .long lluno
4282: #
4283: .long o$alt # alternation
4284: .long c$alt
4285: .long llalt
4286: .long rralt
4287: #page
4288: #
4289: # OPERATOR DOPE VECTORS (CONTINUED)
4290: #
4291: .long 5 # unary vertical bar
4292: .long c$uuo
4293: .long lluno
4294: #
4295: .long 0 # binary at
4296: .long c$ubo
4297: .long llats
4298: .long rrats
4299: #
4300: .long o$cas # cursor assignment
4301: .long c$unm
4302: .long lluno
4303: #
4304: .long 2 # binary number sign
4305: .long c$ubo
4306: .long llnum
4307: .long rrnum
4308: #
4309: .long 7 # unary number sign
4310: .long c$uuo
4311: .long lluno
4312: #
4313: .long o$dvd # division
4314: .long c$bvl
4315: .long lldvd
4316: .long rrdvd
4317: #
4318: .long 9 # unary slash
4319: .long c$uuo
4320: .long lluno
4321: #
4322: .long o$mlt # multiplication
4323: .long c$bvl
4324: .long llmlt
4325: .long rrmlt
4326: #page
4327: #
4328: # OPERATOR DOPE VECTORS (CONTINUED)
4329: #
4330: .long 0 # deferred expression
4331: .long c$def
4332: .long lluno
4333: #
4334: .long 3 # binary percent
4335: .long c$ubo
4336: .long llpct
4337: .long rrpct
4338: #
4339: .long 8 # unary percent
4340: .long c$uuo
4341: .long lluno
4342: #
4343: .long o$exp # exponentiation
4344: .long c$bvl
4345: .long llexp
4346: .long rrexp
4347: #
4348: .long 10 # unary exclamation
4349: .long c$uuo
4350: .long lluno
4351: #
4352: .long o$ima # immediate assignment
4353: .long c$bvn
4354: .long lldld
4355: .long rrdld
4356: #
4357: .long o$inv # indirection
4358: .long c$ind
4359: .long lluno
4360: #
4361: .long 4 # binary not
4362: .long c$ubo
4363: .long llnot
4364: .long rrnot
4365: #
4366: .long 0 # negation
4367: .long c$neg
4368: .long lluno
4369: #page
4370: #
4371: # OPERATOR DOPE VECTORS (CONTINUED)
4372: #
4373: .long o$sub # subtraction
4374: .long c$bvl
4375: .long llplm
4376: .long rrplm
4377: #
4378: .long o$com # complementation
4379: .long c$uvl
4380: .long lluno
4381: #
4382: .long o$add # addition
4383: .long c$bvl
4384: .long llplm
4385: .long rrplm
4386: #
4387: .long o$aff # affirmation
4388: .long c$uvl
4389: .long lluno
4390: #
4391: .long o$pas # pattern assignment
4392: .long c$bvn
4393: .long lldld
4394: .long rrdld
4395: #
4396: .long o$nam # name reference
4397: .long c$unm
4398: .long lluno
4399: #
4400: # SPECIAL DVS FOR GOTO OPERATORS (SEE PROCEDURE SCNGF)
4401: #
4402: opdvd: .long o$god # direct goto
4403: .long c$uvl
4404: .long lluno
4405: #
4406: opdvn: .long o$goc # complex normal goto
4407: .long c$unm
4408: .long lluno
4409: #page
4410: #
4411: # OPERATOR ENTRY ADDRESS POINTERS, USED IN CODE
4412: #
4413: oamn$: .long o$amn # array ref (multi-subs by value)
4414: oamv$: .long o$amv # array ref (multi-subs by value)
4415: oaon$: .long o$aon # array ref (one sub by name)
4416: oaov$: .long o$aov # array ref (one sub by value)
4417: ocer$: .long o$cer # compilation error
4418: ofex$: .long o$fex # failure in expression evaluation
4419: ofif$: .long o$fif # failure during goto evaluation
4420: ofnc$: .long o$fnc # function call (more than one arg)
4421: ofne$: .long o$fne # function name error
4422: ofns$: .long o$fns # function call (single argument)
4423: ogof$: .long o$gof # set goto failure trap
4424: oinn$: .long o$inn # indirection by name
4425: okwn$: .long o$kwn # keyword reference by name
4426: olex$: .long o$lex # load expression by name
4427: olpt$: .long o$lpt # load pattern
4428: olvn$: .long o$lvn # load variable name
4429: onta$: .long o$nta # negation, first entry
4430: ontb$: .long o$ntb # negation, second entry
4431: ontc$: .long o$ntc # negation, third entry
4432: opmn$: .long o$pmn # pattern match by name
4433: opms$: .long o$pms # pattern match (statement)
4434: opop$: .long o$pop # pop top stack item
4435: ornm$: .long o$rnm # return name from expression
4436: orpl$: .long o$rpl # pattern replacement
4437: orvl$: .long o$rvl # return value from expression
4438: osla$: .long o$sla # selection, first entry
4439: oslb$: .long o$slb # selection, second entry
4440: oslc$: .long o$slc # selection, third entry
4441: osld$: .long o$sld # selection, fourth entry
4442: ostp$: .long o$stp # stop execution
4443: ounf$: .long o$unf # unexpected failure
4444: #page
4445: #
4446: # TABLE OF NAMES OF UNDEFINED BINARY OPERATORS FOR OPSYN
4447: #
4448: opsnb: .long ch$at # at
4449: .long ch$am # ampersand
4450: .long ch$nm # number
4451: .long ch$pc # percent
4452: .long ch$nt # not
4453: #
4454: # TABLE OF NAMES OF UNDEFINED UNARY OPERATORS FOR OPSYN
4455: #
4456: opnsu: .long ch$br # vertical bar
4457: .long ch$eq # equal
4458: .long ch$nm # number
4459: .long ch$pc # percent
4460: .long ch$sl # slash
4461: .long ch$ex # exclamation
4462: #
4463: # ADDRESS CONST CONTAINING PROFILE TABLE ENTRY SIZE
4464: #
4465: pfi2a: .long pf$i2
4466: #
4467: # PROFILER MESSAGE STRINGS
4468: #
4469: pfms1: .long b$scl
4470: .long 15
4471: .ascii "PROGRAM PROFILE"
4472: .align 2
4473: pfms2: .long b$scl
4474: .long 42
4475: .ascii "STMT NUMBER OF -- EXECUTION TIME --"
4476: .align 2
4477: pfms3: .long b$scl
4478: .long 47
4479: .ascii "NUMBER EXECUTIONS TOTAL(MSEC) PER EXCN(MCSEC)"
4480: .align 2
4481: #
4482: #
4483: # REAL CONSTANTS FOR GENERAL USE. NOTE THAT THE CONSTANTS
4484: # STARTING AT REAV1 FORM A POWERS OF TEN TABLE (GTSTG)
4485: #
4486: reav0: .float 0f0.0 # 0.0
4487: reap1: .float 0f0.1 # 0.1
4488: reap5: .float 0f0.5 # 0.5
4489: reav1: .float 0f1.0 # 10**0
4490: reavt: .float 0f1.0e+1 # 10**1
4491: .float 0f1.0e+2 # 10**2
4492: .float 0f1.0e+3 # 10**3
4493: .float 0f1.0e+4 # 10**4
4494: .float 0f1.0e+5 # 10**5
4495: .float 0f1.0e+6 # 10**6
4496: .float 0f1.0e+7 # 10**7
4497: .float 0f1.0e+8 # 10**8
4498: .float 0f1.0e+9 # 10**9
4499: reatt: .float 0f1.0e+10 # 10**10
4500: #page
4501: #
4502: # STRING CONSTANTS (SCBLK FORMAT) FOR DTYPE PROCEDURE
4503: #
4504: scarr: .long b$scl # array
4505: .long 5
4506: .ascii "ARRAY"
4507: .align 2
4508: #
4509: scbuf: .long b$scl # buffer
4510: .long 6
4511: .ascii "BUFFER"
4512: .align 2
4513: #
4514: sccod: .long b$scl # code
4515: .long 4
4516: .ascii "CODE"
4517: .align 2
4518: #
4519: scexp: .long b$scl # expression
4520: .long 10
4521: .ascii "EXPRESSION"
4522: .align 2
4523: #
4524: scext: .long b$scl # external
4525: .long 8
4526: .ascii "EXTERNAL"
4527: .align 2
4528: #
4529: scint: .long b$scl # integer
4530: .long 7
4531: .ascii "INTEGER"
4532: .align 2
4533: #
4534: scnam: .long b$scl # name
4535: .long 4
4536: .ascii "NAME"
4537: .align 2
4538: #
4539: scnum: .long b$scl # numeric
4540: .long 7
4541: .ascii "NUMERIC"
4542: .align 2
4543: #
4544: scpat: .long b$scl # pattern
4545: .long 7
4546: .ascii "PATTERN"
4547: .align 2
4548: #
4549: screa: .long b$scl # real
4550: .long 4
4551: .ascii "REAL"
4552: .align 2
4553: #
4554: scstr: .long b$scl # string
4555: .long 6
4556: .ascii "STRING"
4557: .align 2
4558: #
4559: sctab: .long b$scl # table
4560: .long 5
4561: .ascii "TABLE"
4562: .align 2
4563: #page
4564: #
4565: # STRING CONSTANTS (SCBLK FORMAT) FOR KVRTN (SEE RETRN)
4566: #
4567: scfrt: .long b$scl # freturn
4568: .long 7
4569: .ascii "FRETURN"
4570: .align 2
4571: #
4572: scnrt: .long b$scl # nreturn
4573: .long 7
4574: .ascii "NRETURN"
4575: .align 2
4576: #
4577: scrtn: .long b$scl # return
4578: .long 6
4579: .ascii "RETURN"
4580: .align 2
4581: #
4582: # DATATYPE NAME TABLE FOR DTYPE PROCEDURE. THE ORDER OF
4583: # THESE ENTRIES IS TIED TO THE B$XXX DEFINITIONS FOR BLOCKS
4584: #
4585: scnmt: .long scarr # arblk array
4586: .long scbuf # bfblk buffer
4587: .long sccod # cdblk code
4588: .long scexp # exblk expression
4589: .long scint # icblk integer
4590: .long scnam # nmblk name
4591: .long scpat # p0blk pattern
4592: .long scpat # p1blk pattern
4593: .long scpat # p2blk pattern
4594: .long screa # rcblk real
4595: .long scstr # scblk string
4596: .long scexp # seblk expression
4597: .long sctab # tbblk table
4598: .long scarr # vcblk array
4599: .long scext # xnblk external
4600: .long scext # xrblk external
4601: #
4602: # STRING CONSTANT FOR REAL ZERO
4603: #
4604: scre0: .long b$scl
4605: .long 2
4606: .ascii "0."
4607: .align 2
4608: #page
4609: #
4610: # USED TO RE-INITIALISE KVSTL
4611: #
4612: stlim: .long 50000 # default statement limit
4613: #
4614: # DUMMY FUNCTION BLOCK USED FOR UNDEFINED FUNCTIONS
4615: #
4616: stndf: .long o$fun # ptr to undefined function err call
4617: .long 0 # dummy fargs count for call circuit
4618: #
4619: # DUMMY CODE BLOCK USED FOR UNDEFINED LABELS
4620: #
4621: stndl: .long l$und # code ptr points to undefined lbl
4622: #
4623: # DUMMY OPERATOR BLOCK USED FOR UNDEFINED OPERATORS
4624: #
4625: stndo: .long o$oun # ptr to undefined operator err call
4626: .long 0 # dummy fargs count for call circuit
4627: #
4628: # STANDARD VARIABLE BLOCK. THIS BLOCK IS USED TO INITIALIZE
4629: # THE FIRST SEVEN FIELDS OF A NEWLY CONSTRUCTED VRBLK.
4630: # ITS FORMAT IS TIED TO THE VRBLK DEFINITIONS (SEE GTNVR).
4631: #
4632: stnvr: .long b$vrl # vrget
4633: .long b$vrs # vrsto
4634: .long nulls # vrval
4635: .long b$vrg # vrtra
4636: .long stndl # vrlbl
4637: .long stndf # vrfnc
4638: .long 0 # vrnxt
4639: #page
4640: #
4641: # MESSAGES USED IN END OF RUN PROCESSING (STOPR)
4642: #
4643: stpm1: .long b$scl # in statement
4644: .long 12
4645: .ascii "IN STATEMENT"
4646: .align 2
4647: #
4648: stpm2: .long b$scl
4649: .long 14
4650: .ascii "STMTS EXECUTED"
4651: .align 2
4652: #
4653: stpm3: .long b$scl
4654: .long 13
4655: .ascii "RUN TIME-MSEC"
4656: .align 2
4657: #
4658: stpm4: .long b$scl
4659: .long 12
4660: .ascii "MCSEC / STMT"
4661: .align 2
4662: #
4663: stpm5: .long b$scl
4664: .long 13
4665: .ascii "REGENERATIONS"
4666: .align 2
4667: #
4668: # CHARS FOR /TU/ ENDING CODE
4669: #
4670: strtu: .ascii "TU"
4671: .align 2
4672: #
4673: # TABLE USED BY CONVERT FUNCTION TO CHECK DATATYPE NAME
4674: # THE ENTRIES ARE ORDERED TO CORRESPOND TO BRANCH TABLE
4675: # IN S$CNV
4676: #
4677: svctb: .long scstr # string
4678: .long scint # integer
4679: .long scnam # name
4680: .long scpat # pattern
4681: .long scarr # array
4682: .long sctab # table
4683: .long scexp # expression
4684: .long sccod # code
4685: .long scnum # numeric
4686: .long screa # real
4687: .long scbuf # buffer
4688: .long 0 # zero marks end of list
4689: #page
4690: #
4691: # MESSAGES (SCBLK FORMAT) USED BY TRACE PROCEDURES
4692: #
4693: #
4694: tmasb: .long b$scl # asterisks for trace statement no
4695: .long 13
4696: .ascii "************ "
4697: .align 2
4698: #
4699: tmbeb: .long b$scl # blank-equal-blank
4700: .long 3
4701: .ascii " = "
4702: .align 2
4703: #
4704: # DUMMY TRBLK FOR EXPRESSION VARIABLE
4705: #
4706: trbev: .long b$trt # dummy trblk
4707: #
4708: # DUMMY TRBLK FOR KEYWORD VARIABLE
4709: #
4710: trbkv: .long b$trt # dummy trblk
4711: #
4712: # DUMMY CODE BLOCK TO RETURN CONTROL TO TRXEQ PROCEDURE
4713: #
4714: trxdr: .long o$txr # block points to return routine
4715: trxdc: .long trxdr # pointer to block
4716: #page
4717: #
4718: # STANDARD VARIABLE BLOCKS
4719: #
4720: # SEE SVBLK FORMAT FOR FULL DETAILS OF THE FORMAT. THE
4721: # VRBLKS ARE ORDERED BY LENGTH AND WITHIN EACH LENGTH THE
4722: # ORDER IS ALPHABETICAL BY NAME OF THE VARIABLE.
4723: #
4724: v$eqf: .long svfpr # eq
4725: .long 2
4726: .ascii "EQ"
4727: .align 2
4728: .long s$eqf
4729: .long 2
4730: #
4731: v$gef: .long svfpr # ge
4732: .long 2
4733: .ascii "GE"
4734: .align 2
4735: .long s$gef
4736: .long 2
4737: #
4738: v$gtf: .long svfpr # gt
4739: .long 2
4740: .ascii "GT"
4741: .align 2
4742: .long s$gtf
4743: .long 2
4744: #
4745: v$lef: .long svfpr # le
4746: .long 2
4747: .ascii "LE"
4748: .align 2
4749: .long s$lef
4750: .long 2
4751: #
4752: v$ltf: .long svfpr # lt
4753: .long 2
4754: .ascii "LT"
4755: .align 2
4756: .long s$ltf
4757: .long 2
4758: #
4759: v$nef: .long svfpr # ne
4760: .long 2
4761: .ascii "NE"
4762: .align 2
4763: .long s$nef
4764: .long 2
4765: #
4766: v$any: .long svfnp # any
4767: .long 3
4768: .ascii "ANY"
4769: .align 2
4770: .long s$any
4771: .long 1
4772: #
4773: v$arb: .long svkvc # arb
4774: .long 3
4775: .ascii "ARB"
4776: .align 2
4777: .long k$arb
4778: .long ndarb
4779: #page
4780: #
4781: # STANDARD VARIABLE BLOCKS (CONTINUED)
4782: #
4783: v$arg: .long svfnn # arg
4784: .long 3
4785: .ascii "ARG"
4786: .align 2
4787: .long s$arg
4788: .long 2
4789: #
4790: v$bal: .long svkvc # bal
4791: .long 3
4792: .ascii "BAL"
4793: .align 2
4794: .long k$bal
4795: .long ndbal
4796: #
4797: v$end: .long svlbl # end
4798: .long 3
4799: .ascii "END"
4800: .align 2
4801: .long l$end
4802: #
4803: v$len: .long svfnp # len
4804: .long 3
4805: .ascii "LEN"
4806: .align 2
4807: .long s$len
4808: .long 1
4809: #
4810: v$leq: .long svfpr # leq
4811: .long 3
4812: .ascii "LEQ"
4813: .align 2
4814: .long s$leq
4815: .long 2
4816: #
4817: v$lge: .long svfpr # lge
4818: .long 3
4819: .ascii "LGE"
4820: .align 2
4821: .long s$lge
4822: .long 2
4823: #
4824: v$lgt: .long svfpr # lgt
4825: .long 3
4826: .ascii "LGT"
4827: .align 2
4828: .long s$lgt
4829: .long 2
4830: #
4831: v$lle: .long svfpr # lle
4832: .long 3
4833: .ascii "LLE"
4834: .align 2
4835: .long s$lle
4836: .long 2
4837: #page
4838: #
4839: # STANDARD VARIABLE BLOCKS (CONTINUED)
4840: #
4841: v$llt: .long svfpr # llt
4842: .long 3
4843: .ascii "LLT"
4844: .align 2
4845: .long s$llt
4846: .long 2
4847: #
4848: v$lne: .long svfpr # lne
4849: .long 3
4850: .ascii "LNE"
4851: .align 2
4852: .long s$lne
4853: .long 2
4854: #
4855: v$pos: .long svfnp # pos
4856: .long 3
4857: .ascii "POS"
4858: .align 2
4859: .long s$pos
4860: .long 1
4861: #
4862: v$rem: .long svkvc # rem
4863: .long 3
4864: .ascii "REM"
4865: .align 2
4866: .long k$rem
4867: .long ndrem
4868: #
4869: v$set: .long svfnn # set
4870: .long 3
4871: .ascii "SET"
4872: .align 2
4873: .long s$set
4874: .long 3
4875: #
4876: v$tab: .long svfnp # tab
4877: .long 3
4878: .ascii "TAB"
4879: .align 2
4880: .long s$tab
4881: .long 1
4882: #
4883: v$cas: .long svknm # case
4884: .long 4
4885: .ascii "CASE"
4886: .align 2
4887: .long k$cas
4888: #
4889: v$chr: .long svfnp # char
4890: .long 4
4891: .ascii "CHAR"
4892: .align 2
4893: .long s$chr
4894: .long 1
4895: #
4896: v$cod: .long svfnk # code
4897: .long 4
4898: .ascii "CODE"
4899: .align 2
4900: .long k$cod
4901: .long s$cod
4902: .long 1
4903: #
4904: v$cop: .long svfnn # copy
4905: .long 4
4906: .ascii "COPY"
4907: .align 2
4908: .long s$cop
4909: .long 1
4910: #page
4911: #
4912: # STANDARD VARIABLE BLOCKS (CONTINUED)
4913: #
4914: v$dat: .long svfnn # data
4915: .long 4
4916: .ascii "DATA"
4917: .align 2
4918: .long s$dat
4919: .long 1
4920: #
4921: v$dte: .long svfnn # date
4922: .long 4
4923: .ascii "DATE"
4924: .align 2
4925: .long s$dte
4926: .long 0
4927: #
4928: v$dmp: .long svfnk # dump
4929: .long 4
4930: .ascii "DUMP"
4931: .align 2
4932: .long k$dmp
4933: .long s$dmp
4934: .long 1
4935: #
4936: v$dup: .long svfnn # dupl
4937: .long 4
4938: .ascii "DUPL"
4939: .align 2
4940: .long s$dup
4941: .long 2
4942: #
4943: v$evl: .long svfnn # eval
4944: .long 4
4945: .ascii "EVAL"
4946: .align 2
4947: .long s$evl
4948: .long 1
4949: #
4950: v$ext: .long svfnn # exit
4951: .long 4
4952: .ascii "EXIT"
4953: .align 2
4954: .long s$ext
4955: .long 1
4956: #
4957: v$fal: .long svkvc # fail
4958: .long 4
4959: .ascii "FAIL"
4960: .align 2
4961: .long k$fal
4962: .long ndfal
4963: #
4964: v$hst: .long svfnn # host
4965: .long 4
4966: .ascii "HOST"
4967: .align 2
4968: .long s$hst
4969: .long 3
4970: #page
4971: #
4972: # STANDARD VARIABLE BLOCKS (CONTINUED)
4973: #
4974: v$itm: .long svfnf # item
4975: .long 4
4976: .ascii "ITEM"
4977: .align 2
4978: .long s$itm
4979: .long 999
4980: #
4981: v$lod: .long svfnn # load
4982: .long 4
4983: .ascii "LOAD"
4984: .align 2
4985: .long s$lod
4986: .long 2
4987: #
4988: v$lpd: .long svfnp # lpad
4989: .long 4
4990: .ascii "LPAD"
4991: .align 2
4992: .long s$lpd
4993: .long 3
4994: #
4995: v$rpd: .long svfnp # rpad
4996: .long 4
4997: .ascii "RPAD"
4998: .align 2
4999: .long s$rpd
5000: .long 3
5001: #
5002: v$rps: .long svfnp # rpos
5003: .long 4
5004: .ascii "RPOS"
5005: .align 2
5006: .long s$rps
5007: .long 1
5008: #
5009: v$rtb: .long svfnp # rtab
5010: .long 4
5011: .ascii "RTAB"
5012: .align 2
5013: .long s$rtb
5014: .long 1
5015: #
5016: v$si$: .long svfnp # size
5017: .long 4
5018: .ascii "SIZE"
5019: .align 2
5020: .long s$si$
5021: .long 1
5022: #
5023: #
5024: v$srt: .long svfnn # sort
5025: .long 4
5026: .ascii "SORT"
5027: .align 2
5028: .long s$srt
5029: .long 2
5030: v$spn: .long svfnp # span
5031: .long 4
5032: .ascii "SPAN"
5033: .align 2
5034: .long s$spn
5035: .long 1
5036: #page
5037: #
5038: # STANDARD VARIABLE BLOCKS (CONTINUED)
5039: #
5040: v$stn: .long svknm # stno
5041: .long 4
5042: .ascii "STNO"
5043: .align 2
5044: .long k$stn
5045: #
5046: v$tim: .long svfnn # time
5047: .long 4
5048: .ascii "TIME"
5049: .align 2
5050: .long s$tim
5051: .long 0
5052: #
5053: v$trm: .long svfnk # trim
5054: .long 4
5055: .ascii "TRIM"
5056: .align 2
5057: .long k$trm
5058: .long s$trm
5059: .long 1
5060: #
5061: v$abe: .long svknm # abend
5062: .long 5
5063: .ascii "ABEND"
5064: .align 2
5065: .long k$abe
5066: #
5067: v$abo: .long svkvl # abort
5068: .long 5
5069: .ascii "ABORT"
5070: .align 2
5071: .long k$abo
5072: .long l$abo
5073: .long ndabo
5074: #
5075: v$app: .long svfnf # apply
5076: .long 5
5077: .ascii "APPLY"
5078: .align 2
5079: .long s$app
5080: .long 999
5081: #
5082: v$abn: .long svfnp # arbno
5083: .long 5
5084: .ascii "ARBNO"
5085: .align 2
5086: .long s$abn
5087: .long 1
5088: #
5089: v$arr: .long svfnn # array
5090: .long 5
5091: .ascii "ARRAY"
5092: .align 2
5093: .long s$arr
5094: .long 2
5095: #page
5096: #
5097: # STANDARD VARIABLE BLOCKS (CONTINUED)
5098: #
5099: v$brk: .long svfnp # break
5100: .long 5
5101: .ascii "BREAK"
5102: .align 2
5103: .long s$brk
5104: .long 1
5105: #
5106: v$clr: .long svfnn # clear
5107: .long 5
5108: .ascii "CLEAR"
5109: .align 2
5110: .long s$clr
5111: .long 1
5112: #
5113: v$ejc: .long svfnn # eject
5114: .long 5
5115: .ascii "EJECT"
5116: .align 2
5117: .long s$ejc
5118: .long 1
5119: #
5120: v$fen: .long svfpk # fence
5121: .long 5
5122: .ascii "FENCE"
5123: .align 2
5124: .long k$fen
5125: .long s$fnc
5126: .long 1
5127: .long ndfen
5128: #
5129: v$fld: .long svfnn # field
5130: .long 5
5131: .ascii "FIELD"
5132: .align 2
5133: .long s$fld
5134: .long 2
5135: #
5136: v$idn: .long svfpr # ident
5137: .long 5
5138: .ascii "IDENT"
5139: .align 2
5140: .long s$idn
5141: .long 2
5142: #
5143: v$inp: .long svfnk # input
5144: .long 5
5145: .ascii "INPUT"
5146: .align 2
5147: .long k$inp
5148: .long s$inp
5149: .long 3
5150: #
5151: v$loc: .long svfnn # local
5152: .long 5
5153: .ascii "LOCAL"
5154: .align 2
5155: .long s$loc
5156: .long 2
5157: #page
5158: #
5159: # STANDARD VARIABLE BLOCKS (CONTINUED)
5160: #
5161: v$ops: .long svfnn # opsyn
5162: .long 5
5163: .ascii "OPSYN"
5164: .align 2
5165: .long s$ops
5166: .long 3
5167: #
5168: v$rmd: .long svfnp # remdr
5169: .long 5
5170: .ascii "REMDR"
5171: .align 2
5172: .long s$rmd
5173: .long 2
5174: #
5175: v$rsr: .long svfnn # rsort
5176: .long 5
5177: .ascii "RSORT"
5178: .align 2
5179: .long s$rsr
5180: .long 2
5181: #
5182: v$tbl: .long svfnn # table
5183: .long 5
5184: .ascii "TABLE"
5185: .align 2
5186: .long s$tbl
5187: .long 3
5188: #
5189: v$tra: .long svfnk # trace
5190: .long 5
5191: .ascii "TRACE"
5192: .align 2
5193: .long k$tra
5194: .long s$tra
5195: .long 4
5196: #
5197: v$anc: .long svknm # anchor
5198: .long 6
5199: .ascii "ANCHOR"
5200: .align 2
5201: .long k$anc
5202: #
5203: v$apn: .long svfnn
5204: .long 6
5205: .ascii "APPEND"
5206: .align 2
5207: .long s$apn
5208: .long 2
5209: #
5210: v$bkx: .long svfnp # breakx
5211: .long 6
5212: .ascii "BREAKX"
5213: .align 2
5214: .long s$bkx
5215: .long 1
5216: #
5217: v$buf: .long svfnn # buffer
5218: .long 6
5219: .ascii "BUFFER"
5220: .align 2
5221: .long s$buf
5222: .long 2
5223: #
5224: v$def: .long svfnn # define
5225: .long 6
5226: .ascii "DEFINE"
5227: .align 2
5228: .long s$def
5229: .long 2
5230: #
5231: v$det: .long svfnn # detach
5232: .long 6
5233: .ascii "DETACH"
5234: .align 2
5235: .long s$det
5236: .long 1
5237: #page
5238: #
5239: # STANDARD VARIABLE BLOCKS (CONTINUED)
5240: #
5241: v$dif: .long svfpr # differ
5242: .long 6
5243: .ascii "DIFFER"
5244: .align 2
5245: .long s$dif
5246: .long 2
5247: #
5248: v$ftr: .long svknm # ftrace
5249: .long 6
5250: .ascii "FTRACE"
5251: .align 2
5252: .long k$ftr
5253: #
5254: v$ins: .long svfnn # insert
5255: .long 6
5256: .ascii "INSERT"
5257: .align 2
5258: .long s$ins
5259: .long 4
5260: #
5261: v$lst: .long svknm # lastno
5262: .long 6
5263: .ascii "LASTNO"
5264: .align 2
5265: .long k$lst
5266: #
5267: v$nay: .long svfnp # notany
5268: .long 6
5269: .ascii "NOTANY"
5270: .align 2
5271: .long s$nay
5272: .long 1
5273: #
5274: v$oup: .long svfnk # output
5275: .long 6
5276: .ascii "OUTPUT"
5277: .align 2
5278: .long k$oup
5279: .long s$oup
5280: .long 3
5281: #
5282: v$ret: .long svlbl # return
5283: .long 6
5284: .ascii "RETURN"
5285: .align 2
5286: .long l$rtn
5287: #
5288: v$rew: .long svfnn # rewind
5289: .long 6
5290: .ascii "REWIND"
5291: .align 2
5292: .long s$rew
5293: .long 1
5294: #
5295: v$stt: .long svfnn # stoptr
5296: .long 6
5297: .ascii "STOPTR"
5298: .align 2
5299: .long s$stt
5300: .long 2
5301: #page
5302: #
5303: # STANDARD VARIABLE BLOCKS (CONTINUED)
5304: #
5305: v$sub: .long svfnn # substr
5306: .long 6
5307: .ascii "SUBSTR"
5308: .align 2
5309: .long s$sub
5310: .long 3
5311: #
5312: v$unl: .long svfnn # unload
5313: .long 6
5314: .ascii "UNLOAD"
5315: .align 2
5316: .long s$unl
5317: .long 1
5318: #
5319: v$col: .long svfnn # collect
5320: .long 7
5321: .ascii "COLLECT"
5322: .align 2
5323: .long s$col
5324: .long 1
5325: #
5326: v$cnv: .long svfnn # convert
5327: .long 7
5328: .ascii "CONVERT"
5329: .align 2
5330: .long s$cnv
5331: .long 2
5332: #
5333: v$enf: .long svfnn # endfile
5334: .long 7
5335: .ascii "ENDFILE"
5336: .align 2
5337: .long s$enf
5338: .long 1
5339: #
5340: v$etx: .long svknm # errtext
5341: .long 7
5342: .ascii "ERRTEXT"
5343: .align 2
5344: .long k$etx
5345: #
5346: v$ert: .long svknm # errtype
5347: .long 7
5348: .ascii "ERRTYPE"
5349: .align 2
5350: .long k$ert
5351: #
5352: v$frt: .long svlbl # freturn
5353: .long 7
5354: .ascii "FRETURN"
5355: .align 2
5356: .long l$frt
5357: #
5358: v$int: .long svfpr # integer
5359: .long 7
5360: .ascii "INTEGER"
5361: .align 2
5362: .long s$int
5363: .long 1
5364: #
5365: v$nrt: .long svlbl # nreturn
5366: .long 7
5367: .ascii "NRETURN"
5368: .align 2
5369: .long l$nrt
5370: #page
5371: #
5372: # STANDARD VARIABLE BLOCKS (CONTINUED)
5373: #
5374: #
5375: v$pfl: .long svknm # profile
5376: .long 7
5377: .ascii "PROFILE"
5378: .align 2
5379: .long k$pfl
5380: #
5381: v$rpl: .long svfnp # replace
5382: .long 7
5383: .ascii "REPLACE"
5384: .align 2
5385: .long s$rpl
5386: .long 3
5387: #
5388: v$rvs: .long svfnp # reverse
5389: .long 7
5390: .ascii "REVERSE"
5391: .align 2
5392: .long s$rvs
5393: .long 1
5394: #
5395: v$rtn: .long svknm # rtntype
5396: .long 7
5397: .ascii "RTNTYPE"
5398: .align 2
5399: .long k$rtn
5400: #
5401: v$stx: .long svfnn # setexit
5402: .long 7
5403: .ascii "SETEXIT"
5404: .align 2
5405: .long s$stx
5406: .long 1
5407: #
5408: v$stc: .long svknm # stcount
5409: .long 7
5410: .ascii "STCOUNT"
5411: .align 2
5412: .long k$stc
5413: #
5414: v$stl: .long svknm # stlimit
5415: .long 7
5416: .ascii "STLIMIT"
5417: .align 2
5418: .long k$stl
5419: #
5420: v$suc: .long svkvc # succeed
5421: .long 7
5422: .ascii "SUCCEED"
5423: .align 2
5424: .long k$suc
5425: .long ndsuc
5426: #
5427: v$alp: .long svkwc # alphabet
5428: .long 8
5429: .ascii "ALPHABET"
5430: .align 2
5431: .long k$alp
5432: #
5433: v$cnt: .long svlbl # continue
5434: .long 8
5435: .ascii "CONTINUE"
5436: .align 2
5437: .long l$cnt
5438: #page
5439: #
5440: # STANDARD VARIABLE BLOCKS (CONTINUED)
5441: #
5442: v$dtp: .long svfnp # datatype
5443: .long 8
5444: .ascii "DATATYPE"
5445: .align 2
5446: .long s$dtp
5447: .long 1
5448: #
5449: v$erl: .long svknm # errlimit
5450: .long 8
5451: .ascii "ERRLIMIT"
5452: .align 2
5453: .long k$erl
5454: #
5455: v$fnc: .long svknm # fnclevel
5456: .long 8
5457: .ascii "FNCLEVEL"
5458: .align 2
5459: .long k$fnc
5460: #
5461: v$mxl: .long svknm # maxlngth
5462: .long 8
5463: .ascii "MAXLNGTH"
5464: .align 2
5465: .long k$mxl
5466: #
5467: v$ter: .long 0 # terminal
5468: .long 8
5469: .ascii "TERMINAL"
5470: .align 2
5471: .long 0
5472: #
5473: v$pro: .long svfnn # prototype
5474: .long 9
5475: .ascii "PROTOTYPE"
5476: .align 2
5477: .long s$pro
5478: .long 1
5479: #
5480: .long 0 # dummy entry to end list
5481: .long 10 # length gt 9 (prototype)
5482: #page
5483: #
5484: # LIST OF SVBLK POINTERS FOR KEYWORDS TO BE DUMPED. THE
5485: # LIST IS IN THE ORDER WHICH APPEARS ON THE DUMP OUTPUT.
5486: #
5487: vdmkw: .long v$anc # anchor
5488: .long v$cas # ccase
5489: .long v$cod # code
5490: .long v$dmp # dump
5491: .long v$erl # errlimit
5492: .long v$etx # errtext
5493: .long v$ert # errtype
5494: .long v$fnc # fnclevel
5495: .long v$ftr # ftrace
5496: .long v$inp # input
5497: .long v$lst # lastno
5498: .long v$mxl # maxlength
5499: .long v$oup # output
5500: .long v$pfl # profile
5501: .long v$rtn # rtntype
5502: .long v$stc # stcount
5503: .long v$stl # stlimit
5504: .long v$stn # stno
5505: .long v$tra # trace
5506: .long v$trm # trim
5507: .long 0 # end of list
5508: #
5509: # TABLE USED BY GTNVR TO SEARCH SVBLK LISTS
5510: #
5511: vsrch: .long 0 # dummy entry to get proper indexing
5512: .long v$eqf # start of 1 char variables (none)
5513: .long v$eqf # start of 2 char variables
5514: .long v$any # start of 3 char variables
5515: .long v$cas # start of 4 char variables
5516: .long v$abe # start of 5 char variables
5517: .long v$anc # start of 6 char variables
5518: .long v$col # start of 7 char variables
5519: .long v$alp # start of 8 char variables
5520: .long v$pro # start of 9 char variables
5521: #title s p i t b o l -- working storage section
5522: #
5523: # THE WORKING STORAGE SECTION CONTAINS AREAS WHICH ARE
5524: # CHANGED DURING EXECUTION OF THE PROGRAM. THE VALUE
5525: # ASSEMBLED IS THE INITIAL VALUE BEFORE EXECUTION STARTS.
5526: #
5527: # ALL THESE AREAS ARE FIXED LENGTH AREAS. VARIABLE LENGTH
5528: # DATA IS STORED IN THE STATIC OR DYNAMIC REGIONS OF THE
5529: # ALLOCATED DATA AREAS.
5530: #
5531: # THE VALUES IN THIS AREA ARE DESCRIBED EITHER AS WORK
5532: # AREAS OR AS GLOBAL VALUES. A WORK AREA IS USED IN AN
5533: # EPHEMERAL MANNER AND THE VALUE IS NOT SAVED FROM ONE
5534: # ENTRY INTO A ROUTINE TO ANOTHER. A GLOBAL VALUE IS A
5535: # LESS TEMPORARY LOCATION WHOSE VALUE IS SAVED FROM ONE
5536: # CALL TO ANOTHER.
5537: #
5538: # A GENERAL PART OF THE APPROACH IN THIS PROGRAM IS NOT
5539: # TO OVERLAP WORK AREAS BETWEEN PROCEDURES EVEN THOUGH A
5540: # SMALL AMOUNT OF SPACE COULD BE SAVED. SUCH OVERLAP IS
5541: # CONSIDERED A SOURCE OF PROGRAM ERRORS AND DECREASES THE
5542: # INFORMATION LEFT BEHIND AFTER A SYSTEM CRASH OF ANY KIND.
5543: #
5544: # THE NAMES OF THESE LOCATIONS ARE LABELS WITH FIVE LETTER
5545: # (A-Y,$) NAMES. AS FAR AS POSSIBLE THE ORDER IS KEPT
5546: # ALPHABETICAL BY THESE NAMES BUT IN SOME CASES THERE
5547: # ARE SLIGHT DEPARTURES CAUSED BY OTHER ORDER REQUIREMENTS.
5548: #
5549: # UNLESS OTHERWISE DOCUMENTED, THE ORDER OF WORK AREAS
5550: # DOES NOT AFFECT THE EXECUTION OF THE SPITBOL PROGRAM.
5551: #
5552: .data 1
5553: #sec # start of working storage section
5554: #page
5555: #
5556: # THIS AREA IS NOT CLEARED BY INITIAL CODE
5557: #
5558: cmlab: .long b$scl # string used to check label legality
5559: .long 2
5560: .ascii " "
5561: .align 2
5562: #
5563: # LABEL TO MARK START OF WORK AREA
5564: #
5565: aaaaa: .long 0
5566: #
5567: # WORK AREAS FOR ALLOC PROCEDURE
5568: #
5569: aldyn: .long 0 # amount of dynamic store
5570: alfsf: .long 0 # factor in free store pcntage check
5571: allia: .long 0 # dump ia
5572: allsv: .long 0 # save wb in alloc
5573: #
5574: # WORK AREAS FOR ALOST PROCEDURE
5575: #
5576: alsta: .long 0 # save wa in alost
5577: #
5578: # SAVE AREAS FOR ARRAY FUNCTION (S$ARR)
5579: #
5580: arcdm: .long 0 # count dimensions
5581: arnel: .long 0 # count elements
5582: arptr: .long 0 # offset ptr into arblk
5583: arsvl: .long 0 # save integer low bound
5584: #page
5585: # WORK AREAS FOR ARREF ROUTINE
5586: #
5587: arfsi: .long 0 # save current evolving subscript
5588: arfxs: .long 0 # save base stack pointer
5589: #
5590: # WORK AREAS FOR B$EFC BLOCK ROUTINE
5591: #
5592: befof: .long 0 # save offset ptr into efblk
5593: #
5594: # WORK AREAS FOR B$PFC BLOCK ROUTINE
5595: #
5596: bpfpf: .long 0 # save pfblk pointer
5597: bpfsv: .long 0 # save old function value
5598: bpfxt: .long 0 # pointer to stacked arguments
5599: #
5600: # SAVE AREAS FOR COLLECT FUNCTION (S$COL)
5601: #
5602: clsvi: .long 0 # save integer argument
5603: #
5604: # GLOBAL VALUES FOR CMPIL PROCEDURE
5605: #
5606: cmerc: .long 0 # count of initial compile errors
5607: cmpxs: .long 0 # save stack ptr in case of errors
5608: cmpsn: .long 1 # number of next statement to compile
5609: cmpss: .long 0 # save subroutine stack ptr
5610: #
5611: # WORK AREA FOR CNCRD
5612: #
5613: cnscc: .long 0 # pointer to control card string
5614: cnswc: .long 0 # word count
5615: cnr$t: .long 0 # pointer to r$ttl or r$stl
5616: cnttl: .long 0 # flag for -title, -stitl
5617: #
5618: # WORK AREAS FOR CONVERT FUNCTION (S$CNV)
5619: #
5620: cnvtp: .long 0 # save ptr into scvtb
5621: #
5622: # FLAG FOR SUPPRESSION OF COMPILATION STATISTICS.
5623: #
5624: cpsts: .long 0 # suppress comp. stats if non zero
5625: #
5626: # GLOBAL VALUES FOR CONTROL CARD SWITCHES
5627: #
5628: cswdb: .long 0 # 0/1 for -single/-double
5629: cswer: .long 0 # 0/1 for -errors/-noerrors
5630: cswex: .long 0 # 0/1 for -execute/-noexecute
5631: cswfl: .long 1 # 0/1 for -nofail/-fail
5632: cswin: .long iniln # xxx for -inxxx
5633: cswls: .long 1 # 0/1 for -nolist/-list
5634: cswno: .long 0 # 0/1 for -optimise/-noopt
5635: cswpr: .long 0 # 0/1 for -noprint/-print
5636: #
5637: # GLOBAL LOCATION USED BY PATST PROCEDURE
5638: #
5639: ctmsk: .long 0 # last bit position used in r$ctp
5640: curid: .long 0 # current id value
5641: #page
5642: #
5643: # GLOBAL VALUE FOR CDWRD PROCEDURE
5644: #
5645: cwcof: .long 0 # next word offset in current ccblk
5646: #
5647: # WORK AREAS FOR DATA FUNCTION (S$DAT)
5648: #
5649: datdv: .long 0 # save vrblk ptr for datatype name
5650: datxs: .long 0 # save initial stack pointer
5651: #
5652: # WORK AREAS FOR DEFINE FUNCTION (S$DEF)
5653: #
5654: deflb: .long 0 # save vrblk ptr for label
5655: defna: .long 0 # count function arguments
5656: defvr: .long 0 # save vrblk ptr for function name
5657: defxs: .long 0 # save initial stack pointer
5658: #
5659: # WORK AREAS FOR DUMPR PROCEDURE
5660: #
5661: dmarg: .long 0 # dump argument
5662: dmpkb: .long b$kvt # dummy kvblk for use in dumpr
5663: dmpkt: .long trbkv # kvvar trblk pointer
5664: dmpkn: .long 0 # keyword number (must follow dmpkb)
5665: dmpsa: .long 0 # preserve wa over prtvl call
5666: dmpsv: .long 0 # general scratch save
5667: dmvch: .long 0 # chain pointer for variable blocks
5668: dmpch: .long 0 # save sorted vrblk chain pointer
5669: #
5670: # GLOBAL LOCATIONS FOR DYNAMIC STORAGE POINTERS
5671: #
5672: dnamb: .long 0 # start of dynamic area
5673: dnamp: .long 0 # next available loc in dynamic area
5674: dname: .long 0 # end of available dynamic area
5675: #
5676: # WORK AREA FOR DTACH
5677: #
5678: dtcnb: .long 0 # name base
5679: dtcnm: .long 0 # name ptr
5680: #
5681: # WORK AREAS FOR DUPL FUNCTION (S$DUP)
5682: #
5683: dupsi: .long 0 # store integer string length
5684: #
5685: # WORK AREA FOR ENDFILE (S$ENF)
5686: #
5687: enfch: .long 0 # for iochn chain head
5688: #
5689: # WORK AREA FOR ERROR PROCESSING.
5690: #
5691: erich: .long 0 # copy error reports to int.chan if 1
5692: erlst: .long 0 # for listr when errors go to int.ch.
5693: errft: .long 0 # fatal error flag
5694: errsp: .long 0 # error suppression flag
5695: #page
5696: #
5697: # DUMP AREA FOR ERTEX
5698: #
5699: ertwa: .long 0 # save wa
5700: ertwb: .long 0 # save wb
5701: #
5702: # GLOBAL VALUES FOR EVALI
5703: #
5704: evlin: .long p$len # dummy pattern block pcode
5705: evlis: .long 0 # pointer to subsequent node
5706: evliv: .long 0 # value of parameter
5707: # WORK AREA FOR EXPAN
5708: #
5709: expsv: .long 0 # save op dope vector pointer
5710: #
5711: # FLAG FOR SUPPRESSION OF EXECUTION STATS
5712: #
5713: exsts: .long 0 # suppress exec stats if set
5714: #
5715: # GLOBAL VALUES FOR EXFAL AND RETURN
5716: #
5717: flprt: .long 0 # location of fail offset for return
5718: flptr: .long 0 # location of failure offset on stack
5719: #
5720: # WORK AREAS FOR GBCOL PROCEDURE
5721: #
5722: gbcfl: .long 0 # garbage collector active flag
5723: gbclm: .long 0 # pointer to last move block (pass 3)
5724: gbcnm: .long 0 # dummy first move block
5725: gbcns: .long 0 # rest of dummy block (follows gbcnm)
5726: gbsva: .long 0 # save wa
5727: gbsvb: .long 0 # save wb
5728: gbsvc: .long 0 # save wc
5729: #
5730: # GLOBAL LOCATION TO COUNT GARBAGE COLLECTIONS (GBCOL)
5731: #
5732: gbcnt: .long 0 # count of garbage collections
5733: #
5734: # WORK AREAS FOR GTNVR PROCEDURE
5735: #
5736: gnvhe: .long 0 # ptr to end of hash chain
5737: gnvnw: .long 0 # number of words in string name
5738: gnvsa: .long 0 # save wa
5739: gnvsb: .long 0 # save wb
5740: gnvsp: .long 0 # pointer into vsrch table
5741: gnvst: .long 0 # pointer to chars of string
5742: #
5743: # GLOBAL VALUE FOR GTCOD AND GTEXP
5744: #
5745: gtcef: .long 0 # save fail ptr in case of error
5746: #
5747: # WORK AREAS FOR GTINT
5748: #
5749: gtina: .long 0 # save wa
5750: gtinb: .long 0 # save wb
5751: #page
5752: #
5753: # WORK AREAS FOR GTNUM PROCEDURE
5754: #
5755: gtnnf: .long 0 # zero/nonzero for result +/-
5756: gtnsi: .long 0 # general integer save
5757: gtndf: .long 0 # 0/1 for dec point so far no/yes
5758: gtnes: .long 0 # zero/nonzero exponent +/-
5759: gtnex: .long 0 # real exponent
5760: gtnsc: .long 0 # scale (places after point)
5761: gtnsr: .float 0f0.0 # general real save
5762: gtnrd: .long 0 # flag for ok real number
5763: #
5764: # WORK AREAS FOR GTPAT PROCEDURE
5765: #
5766: gtpsb: .long 0 # save wb
5767: #
5768: # WORK AREAS FOR GTSTG PROCEDURE
5769: #
5770: gtssf: .long 0 # 0/1 for result +/-
5771: gtsvc: .long 0 # save wc
5772: gtsvb: .long 0 # save wb
5773: gtswk: .long 0 # ptr to work area for gtstg
5774: gtses: .long 0 # char + or - for exponent +/-
5775: gtsrs: .float 0f0.0 # general real save
5776: #
5777: # GLOBAL LOCATIONS (CONSTANTS) FOR GTSTG PROCEDURE
5778: #
5779: gtsrn: .float 0f0.0 # rounding factor 0.5*10**-cfp$s
5780: gtssc: .float 0f0.0 # scaling value 10**cfp$s
5781: #
5782: # WORK AREAS FOR GTVAR PROCEDURE
5783: #
5784: gtvrc: .long 0 # save wc
5785: #
5786: # FLAG FOR HEADER PRINTING
5787: #
5788: headp: .long 0 # header printed flag
5789: #
5790: # GLOBAL VALUES FOR VARIABLE HASH TABLE
5791: #
5792: hshnb: .long 0 # number of hash buckets
5793: hshtb: .long 0 # pointer to start of vrblk hash tabl
5794: hshte: .long 0 # pointer past end of vrblk hash tabl
5795: #
5796: # WORK AREA FOR INIT
5797: #
5798: iniss: .long 0 # save subroutine stack ptr
5799: initr: .long 0 # save terminal flag
5800: #
5801: # SAVE AREA FOR INSBF
5802: #
5803: insab: .long 0 # entry wa + entry wb
5804: inssa: .long 0 # save entry wa
5805: inssb: .long 0 # save entry wb
5806: inssc: .long 0 # save entry wc
5807: #
5808: # WORK AREAS FOR IOPUT
5809: #
5810: ioptt: .long 0 # type of association
5811: #page
5812: #
5813: # GLOBAL VALUES FOR KEYWORD VALUES WHICH ARE STORED AS ONE
5814: # WORD INTEGERS. THESE VALUES MUST BE ASSEMBLED IN THE
5815: # FOLLOWING ORDER (AS DICTATED BY K$XXX DEFINITION VALUES).
5816: #
5817: kvabe: .long 0 # abend
5818: kvanc: .long 0 # anchor
5819: kvcas: .long 0 # case
5820: kvcod: .long 0 # code
5821: kvdmp: .long 0 # dump
5822: kverl: .long 0 # errlimit
5823: kvert: .long 0 # errtype
5824: kvftr: .long 0 # ftrace
5825: kvinp: .long 1 # input
5826: kvmxl: .long 5000 # maxlength
5827: kvoup: .long 1 # output
5828: kvpfl: .long 0 # profile
5829: kvtra: .long 0 # trace
5830: kvtrm: .long 0 # trim
5831: kvfnc: .long 0 # fnclevel
5832: kvlst: .long 0 # lastno
5833: kvstn: .long 0 # stno
5834: #
5835: # GLOBAL VALUES FOR OTHER KEYWORDS
5836: #
5837: kvalp: .long 0 # alphabet
5838: kvrtn: .long nulls # rtntype (scblk pointer)
5839: kvstl: .long 50000 # stlimit
5840: kvstc: .long 50000 # stcount (counts down from stlimit)
5841: #
5842: # WORK AREAS FOR LOAD FUNCTION
5843: #
5844: lodfn: .long 0 # pointer to vrblk for func name
5845: lodna: .long 0 # count number of arguments
5846: #
5847: # GLOBAL VALUES FOR LISTR PROCEDURE
5848: #
5849: lstlc: .long 0 # count lines on source list page
5850: lstnp: .long 0 # max number of lines on page
5851: lstpf: .long 1 # set nonzero if current image listed
5852: lstpg: .long 0 # current source list page number
5853: lstpo: .long 0 # offset to page nnn message
5854: lstsn: .long 0 # remember last stmnum listed
5855: #
5856: # MAXIMUM SIZE OF SPITBOL OBJECTS
5857: #
5858: mxlen: .long 0 # initialised by sysmx call
5859: #
5860: # EXECUTION CONTROL VARIABLE
5861: #
5862: noxeq: .long 0 # set non-zero to inhibit execution
5863: #
5864: # PROFILER GLOBAL VALUES AND WORK LOCATIONS
5865: #
5866: pfdmp: .long 0 # set non-0 if &profile set non-0
5867: pffnc: .long 0 # set non-0 if funct just entered
5868: pfstm: .long 0 # to store starting time of stmt
5869: pfetm: .long 0 # to store ending time of stmt
5870: pfsvw: .long 0 # to save a w-reg
5871: pftbl: .long 0 # gets adrs of (imag) table base
5872: pfnte: .long 0 # nr of table entries
5873: pfste: .long 0 # gets int rep of table entry size
5874: #
5875: #page
5876: #
5877: # GLOBAL VALUES USED IN PATTERN MATCH ROUTINES
5878: #
5879: pmdfl: .long 0 # pattern assignment flag
5880: pmhbs: .long 0 # history stack base pointer
5881: pmssl: .long 0 # length of subject string in chars
5882: #
5883: # FLAGS USED FOR STANDARD FILE LISTING OPTIONS
5884: #
5885: prich: .long 0 # printer on interactive channel
5886: prstd: .long 0 # tested by prtpg
5887: prsto: .long 0 # standard listing option flag
5888: #
5889: # GLOBAL VALUE FOR PRTNM PROCEDURE
5890: #
5891: prnmv: .long 0 # vrblk ptr from last name search
5892: #
5893: # WORK AREAS FOR PRTNM PROCEDURE
5894: #
5895: prnsi: .long 0 # scratch integer loc
5896: #
5897: # WORK AREAS FOR PRTSN PROCEDURE
5898: #
5899: prsna: .long 0 # save wa
5900: #
5901: # GLOBAL VALUES FOR PRINT PROCEDURES
5902: #
5903: prbuf: .long 0 # ptr to print bfr in static
5904: precl: .long 0 # extended/compact listing flag
5905: prlen: .long 0 # length of print buffer in chars
5906: prlnw: .long 0 # length of print buffer in words
5907: profs: .long 0 # offset to next location in prbuf
5908: prtef: .long 0 # endfile flag
5909: #
5910: # WORK AREAS FOR PRTST PROCEDURE
5911: #
5912: prsva: .long 0 # save wa
5913: prsvb: .long 0 # save wb
5914: prsvc: .long 0 # save char counter
5915: #
5916: # WORK AREA FOR PRTNL
5917: #
5918: prtsa: .long 0 # save wa
5919: prtsb: .long 0 # save wb
5920: #
5921: # WORK AREA FOR PRTVL
5922: #
5923: prvsi: .long 0 # save idval
5924: #
5925: # WORK AREAS FOR PATTERN MATCH ROUTINES
5926: #
5927: psave: .long 0 # temporary save for current node ptr
5928: psavc: .long 0 # save cursor in p$spn, p$str
5929: #page
5930: #
5931: # AMOUNT OF MEMORY RESERVED FOR END OF EXECUTION
5932: #
5933: rsmem: .long 0 # reserve memory
5934: #
5935: # WORK AREAS FOR RETRN ROUTINE
5936: #
5937: rtnbp: .long 0 # to save a block pointer
5938: rtnfv: .long 0 # new function value (result)
5939: rtnsv: .long 0 # old function value (saved value)
5940: #
5941: # RELOCATABLE GLOBAL VALUES
5942: #
5943: # ALL THE POINTERS IN THIS SECTION CAN POINT TO BLOCKS IN
5944: # THE DYNAMIC STORAGE AREA AND MUST BE RELOCATED BY THE
5945: # GARBAGE COLLECTOR. THEY ARE IDENTIFIED BY R$XXX NAMES.
5946: #
5947: r$aaa: .long 0 # start of relocatable values
5948: r$arf: .long 0 # array block pointer for arref
5949: r$ccb: .long 0 # ptr to ccblk being built (cdwrd)
5950: r$cim: .long 0 # ptr to current compiler input str
5951: r$cmp: .long 0 # copy of r$cim used in cmpil
5952: r$cni: .long 0 # ptr to next compiler input string
5953: r$cnt: .long 0 # cdblk pointer for setexit continue
5954: r$cod: .long 0 # pointer to current cdblk or exblk
5955: r$ctp: .long 0 # ptr to current ctblk for patst
5956: r$ert: .long 0 # trblk pointer for errtype trace
5957: r$etx: .long nulls # pointer to errtext string
5958: r$exs: .long 0 # = save xl in expdm
5959: r$fcb: .long 0 # fcblk chain head
5960: r$fnc: .long 0 # trblk pointer for fnclevel trace
5961: r$gtc: .long 0 # keep code ptr for gtcod,gtexp
5962: r$io1: .long 0 # file arg1 for ioput
5963: r$io2: .long 0 # file arg2 for ioput
5964: r$iof: .long 0 # fcblk ptr or 0
5965: r$ion: .long 0 # name base ptr
5966: r$iop: .long 0 # predecessor block ptr for ioput
5967: r$iot: .long 0 # trblk ptr for ioput
5968: r$pmb: .long 0 # buffer ptr in pattern match
5969: r$pms: .long 0 # subject string ptr in pattern match
5970: r$ra2: .long 0 # replace second argument last time
5971: r$ra3: .long 0 # replace third argument last time
5972: r$rpt: .long 0 # ptr to ctblk replace table last usd
5973: r$scp: .long 0 # save pointer from last scane call
5974: r$sxl: .long 0 # preserve xl in sortc
5975: r$sxr: .long 0 # preserve xr in sorta/sortc
5976: r$stc: .long 0 # trblk pointer for stcount trace
5977: r$stl: .long 0 # source listing sub-title
5978: r$sxc: .long 0 # code (cdblk) ptr for setexit trap
5979: r$ttl: .long nulls # source listing title
5980: r$xsc: .long 0 # string pointer for xscan
5981: #page
5982: #
5983: # THE REMAINING POINTERS IN THIS LIST ARE USED TO POINT
5984: # TO FUNCTION BLOCKS FOR NORMALLY UNDEFINED OPERATORS.
5985: #
5986: r$uba: .long stndo # binary at
5987: r$ubm: .long stndo # binary ampersand
5988: r$ubn: .long stndo # binary number sign
5989: r$ubp: .long stndo # binary percent
5990: r$ubt: .long stndo # binary not
5991: r$uub: .long stndo # unary vertical bar
5992: r$uue: .long stndo # unary equal
5993: r$uun: .long stndo # unary number sign
5994: r$uup: .long stndo # unary percent
5995: r$uus: .long stndo # unary slash
5996: r$uux: .long stndo # unary exclamation
5997: r$yyy: .long 0 # last relocatable location
5998: #
5999: # WORK AREAS FOR SUBSTR FUNCTION (S$SUB)
6000: #
6001: sbssv: .long 0 # save third argument
6002: #
6003: # GLOBAL LOCATIONS USED IN SCAN PROCEDURE
6004: #
6005: scnbl: .long 0 # set non-zero if scanned past blanks
6006: scncc: .long 0 # non-zero to scan control card name
6007: scngo: .long 0 # set non-zero to scan goto field
6008: scnil: .long 0 # length of current input image
6009: scnpt: .long 0 # pointer to next location in r$cim
6010: scnrs: .long 0 # set non-zero to signal rescan
6011: scntp: .long 0 # save syntax type from last call
6012: #
6013: # WORK AREAS FOR SCAN PROCEDURE
6014: #
6015: scnsa: .long 0 # save wa
6016: scnsb: .long 0 # save wb
6017: scnsc: .long 0 # save wc
6018: scnse: .long 0 # start of current element
6019: scnof: .long 0 # save offset
6020: #page
6021: #
6022: # WORK AREA USED BY SORTA, SORTC, SORTF, SORTH
6023: #
6024: srtdf: .long 0 # datatype field name
6025: srtfd: .long 0 # found dfblk address
6026: srtff: .long 0 # found field name
6027: srtfo: .long 0 # offset to field name
6028: srtnr: .long 0 # number of rows
6029: srtof: .long 0 # offset within row to sort key
6030: srtrt: .long 0 # root offset
6031: srts1: .long 0 # save offset 1
6032: srts2: .long 0 # save offset 2
6033: srtsc: .long 0 # save wc
6034: srtsf: .long 0 # sort array first row offset
6035: srtsn: .long 0 # save n
6036: srtso: .long 0 # offset to a(0)
6037: srtsr: .long 0 # 0 , non-zero for sort, rsort
6038: srtst: .long 0 # stride from one row to next
6039: srtwc: .long 0 # dump wc
6040: #
6041: # GLOBAL VALUE FOR INDICATING STAGE (SEE ERROR SECTION)
6042: #
6043: stage: .long 0 # initial value = initial compile
6044: #
6045: # GLOBAL VALUES DEFINING EXTENT OF STATIC AREA (ALOST)
6046: #
6047: statb: .long 0 # start of static area
6048: state: .long 0 # end of static area
6049: #page
6050: #
6051: # GLOBAL STACK POINTER
6052: #
6053: stbas: .long 0 # pointer past stack base
6054: #
6055: # WORK AREAS FOR STOPR ROUTINE
6056: #
6057: stpsi: .long 0 # save value of stcount
6058: stpti: .long 0 # save time elapsed
6059: #
6060: # GLOBAL VALUES FOR SETEXIT FUNCTION (S$STX)
6061: #
6062: stxof: .long 0 # failure offset
6063: stxvr: .long nulls # vrblk pointer or null
6064: #
6065: # WORK AREAS FOR TFIND PROCEDURE
6066: #
6067: tfnsi: .long 0 # number of headers
6068: #
6069: # GLOBAL VALUE FOR TIME KEEPING
6070: #
6071: timsx: .long 0 # time at start of execution
6072: timup: .long 0 # set when time up occurs
6073: #
6074: # WORK AREAS FOR XSCAN PROCEDURE
6075: #
6076: xscrt: .long 0 # save return code
6077: xscwb: .long 0 # save register wb
6078: #
6079: # GLOBAL VALUES FOR XSCAN AND XSCNI PROCEDURES
6080: #
6081: xsofs: .long 0 # offset to current location in r$xsc
6082: #
6083: # LABEL TO MARK END OF WORK AREA
6084: #
6085: yyyyy: .long 0
6086: #title s p i t b o l -- initialization
6087: #
6088: # INITIALISATION
6089: # THE FOLLOWING SECTION RECEIVES CONTROL FROM THE SYSTEM
6090: # AT THE START OF A RUN WITH THE REGISTERS SET AS FOLLOWS.
6091: #
6092: # (XS) POINTS PAST STACK BASE
6093: # (XR) POINTS TO FIRST WORD OF DATA AREA
6094: # (XL) POINTS TO LAST WORD OF DATA AREA
6095: #
6096: .text 0
6097: .globl sec04
6098: sec04:
6099: #sec # start of program section
6100: jsb systm # initialise timer
6101: #
6102: # INITIALISE WORK AREA (ESSENTIAL FOR BATCHED RUNS)
6103: #
6104: movl r9,r7 # preserve xr
6105: movl $yyyyy,r6 # point to end of work area
6106: subl2 $aaaaa,r6 # get length of work area
6107: ashl $-2,r6,r6 # convert to words
6108: # count for loop
6109: movl $aaaaa,r9 # set up index register
6110: #
6111: # CLEAR WORK SPACE
6112: #
6113: ini01: clrl (r9)+ # clear a word
6114: sobgtr r6,ini01 # loop till done
6115: movl $stndo,r6 # undefined operators pointer
6116: movl $r$yyy,r8 # point to table end
6117: subl2 $r$uba,r8 # length of undef. operators table
6118: ashl $-2,r8,r8 # convert to words
6119: # loop counter
6120: movl $r$uba,r9 # set up xr
6121: #
6122: # SET CORRECT VALUE INTO UNDEFINED OPERATORS TABLE
6123: #
6124: ini02: movl r6,(r9)+ # store value
6125: sobgtr r8,ini02 # loop till all done
6126: movl $num01,r6 # get a 1
6127: movl r6,cmpsn # statement no
6128: movl r6,cswfl # nofail
6129: movl r6,cswls # list
6130: movl r6,kvinp # input
6131: movl r6,kvoup # output
6132: movl r6,lstpf # nothing for listr yet
6133: movl $iniln,r6 # input image length
6134: movl r6,cswin # -in72
6135: movl $b$kvt,dmpkb # dump
6136: movl $trbkv,dmpkt # dump
6137: movl $p$len,evlin # eval
6138: #page
6139: movl $nulls,r6 # get nullstring pointer
6140: movl r6,kvrtn # return
6141: movl r6,r$etx # errtext
6142: movl r6,r$ttl # title for listing
6143: movl r6,stxvr # setexit
6144: movl r5,timsx # store time in correct place
6145: movl stlim,r5 # get default stlimit
6146: movl r5,kvstl # statement limit
6147: movl r5,kvstc # statement count
6148: movl r7,statb # store start adrs of static
6149: movl $4*e$srs,rsmem # reserve memory
6150: movl sp,stbas # store stack base
6151: #sss iniss # save s-r stack ptr
6152: #
6153: # NOW CONVERT FREE STORE PERCENTAGE TO A SUITABLE FACTOR
6154: # FOR EASY TESTING IN ALLOC ROUTINE.
6155: #
6156: movl intvh,r5 # get 100
6157: divl2 alfsp,r5 # form 100 / alfsp
6158: movl r5,alfsf # store the factor
6159: #
6160: # INITIALIZE VALUES FOR REAL CONVERSION ROUTINE
6161: #
6162: movl $cfp$s,r7 # load counter for significant digits
6163: movf reav1,r2 # load 1.0
6164: #
6165: # LOOP TO COMPUTE 10**(MAX NUMBER SIGNIFICANT DIGITS)
6166: #
6167: ini03: mulf2 reavt,r2 # * 10.0
6168: sobgtr r7,ini03 # loop till done
6169: movf r2,gtssc # store 10**(max sig digits)
6170: movf reap5,r2 # load 0.5
6171: divf2 gtssc,r2 # compute 0.5*10**(max sig digits)
6172: movf r2,gtsrn # store as rounding bias
6173: clrl r8 # set to read parameters
6174: jsb prpar # read them
6175: #page
6176: #
6177: # NOW COMPUTE STARTING ADDRESS FOR DYNAMIC STORE AND IF
6178: # NECESSARY REQUEST MORE MEMORY.
6179: #
6180: subl2 $4*e$srs,r10 # allow for reserve memory
6181: movl prlen,r6 # get print buffer length
6182: addl2 $cfp$a,r6 # add no. of chars in alphabet
6183: addl2 $nstmx,r6 # add chars for gtstg bfr
6184: movab 3+(4*8)(r6),r6 # convert to bytes, allowing a margin
6185: bicl2 $3,r6
6186: movl statb,r9 # point to static base
6187: addl2 r6,r9 # increment for above buffers
6188: addl2 $4*e$hnb,r9 # increment for hash table
6189: addl2 $4*e$sts,r9 # bump for initial static block
6190: jsb sysmx # get mxlen
6191: movl r6,kvmxl # provisionally store as maxlngth
6192: movl r6,mxlen # and as mxlen
6193: cmpl r9,r6 # skip if static hi exceeds mxlen
6194: bgtru ini06
6195: movl r6,r9 # use mxlen instead
6196: addl2 $4,r9 # make bigger than mxlen
6197: #
6198: # HERE TO STORE VALUES WHICH MARK INITIAL DIVISION
6199: # OF DATA AREA INTO STATIC AND DYNAMIC
6200: #
6201: ini06: movl r9,dnamb # dynamic base adrs
6202: movl r9,dnamp # dynamic ptr
6203: tstl r6 # skip if non-zero mxlen
6204: bnequ ini07
6205: subl2 $4,r9 # point a word in front
6206: movl r9,kvmxl # use as maxlngth
6207: movl r9,mxlen # and as mxlen
6208: #page
6209: #
6210: # LOOP HERE IF NECESSARY TILL ENOUGH MEMORY OBTAINED
6211: # SO THAT DNAME IS ABOVE DNAMB
6212: #
6213: ini07: movl r10,dname # store dynamic end address
6214: cmpl dnamb,r10 # skip if high enough
6215: blssu ini09
6216: jsb sysmm # request more memory
6217: moval 0[r9],r9 # get as baus (sgd05)
6218: addl2 r9,r10 # bump by amount obtained
6219: tstl r9 # try again
6220: bnequ ini07
6221: movl $endmo,r9 # point to failure message
6222: movl endml,r6 # message length
6223: jsb syspr # print it (prtst not yet usable)
6224: .long invalid$ # should not fail
6225: jsb sysej # pack up (stopr not yet usable)
6226: #
6227: # INITIALISE PRINT BUFFER WITH BLANK WORDS
6228: #
6229: ini09: movl prlen,r8 # no. of chars in print bfr
6230: movl statb,r9 # point to static again
6231: movl r9,prbuf # print bfr is put at static start
6232: movl $b$scl,(r9)+ # store string type code
6233: movl r8,(r9)+ # and string length
6234: movab 3+(4*0)(r8),r8 # get number of words in buffer
6235: ashl $-2,r8,r8
6236: movl r8,prlnw # store for buffer clear
6237: # words to clear
6238: #
6239: # LOOP TO CLEAR BUFFER
6240: #
6241: ini10: movl nullw,(r9)+ # store blank
6242: sobgtr r8,ini10 # loop
6243: #
6244: # INITIALIZE NUMBER OF HASH HEADERS
6245: #
6246: movl $e$hnb,r6 # get number of hash headers
6247: movl r6,r5 # convert to integer
6248: movl r5,hshnb # store for use by gtnvr procedure
6249: # counter for clearing hash table
6250: movl r9,hshtb # pointer to hash table
6251: #
6252: # LOOP TO CLEAR HASH TABLE
6253: #
6254: ini11: clrl (r9)+ # blank a word
6255: sobgtr r6,ini11 # loop
6256: movl r9,hshte # end of hash table adrs is kept
6257: #
6258: # ALLOCATE WORK AREA FOR GTSTG CONVERSION PROCEDURE
6259: #
6260: movl $nstmx,r6 # get max num chars in output number
6261: movab 3+(4*scsi$)(r6),r6 # no of bytes needed
6262: bicl2 $3,r6
6263: movl r9,gtswk # store bfr adrs
6264: addl2 r6,r9 # bump for work bfr
6265: #page
6266: #
6267: # BUILD ALPHABET STRING FOR ALPHABET KEYWORD AND REPLACE
6268: #
6269: movl r9,kvalp # save alphabet pointer
6270: movl $b$scl,(r9) # string blk type
6271: movl $cfp$a,r8 # no of chars in alphabet
6272: movl r8,4*sclen(r9) # store as string length
6273: movl r8,r7 # copy char count
6274: movab 3+(4*scsi$)(r7),r7 # no. of bytes needed
6275: bicl2 $3,r7
6276: addl2 r9,r7 # current end address for static
6277: movl r7,state # store static end adrs
6278: # loop counter
6279: movab cfp$f(r9),r9 # point to chars of string
6280: clrl r7 # set initial character value
6281: #
6282: # LOOP TO ENTER CHARACTER CODES IN ORDER
6283: #
6284: ini12: movb r7,(r9)+ # store next code
6285: incl r7 # bump code value
6286: sobgtr r8,ini12 # loop till all stored
6287: #csc r9 # complete store characters
6288: #
6289: # INITIALIZE VARIABLE BLOCKS FOR INPUT AND OUTPUT
6290: #
6291: movl $v$inp,r10 # point to string /input/
6292: movl $trtin,r7 # trblk type for input
6293: jsb inout # perform input association
6294: movl $v$oup,r10 # point to string /output/
6295: movl $trtou,r7 # trblk type for output
6296: jsb inout # perform output association
6297: movl initr,r8 # terminal flag
6298: tstl r8 # skip if no terminal
6299: beqlu ini13
6300: jsb prpar # associate terminal
6301: #page
6302: #
6303: # CHECK FOR EXPIRY DATE
6304: #
6305: ini13: jsb sysdc # call date check
6306: movl sp,flptr # in case stack overflows in compiler
6307: #
6308: # NOW COMPILE SOURCE INPUT CODE
6309: #
6310: jsb cmpil # call compiler
6311: movl r9,r$cod # set ptr to first code block
6312: movl $nulls,r$ttl # forget title (reg04)
6313: movl $nulls,r$stl # forget sub-title (reg04)
6314: clrl r$cim # forget compiler input image
6315: clrl r10 # clear dud value
6316: clrl r7 # dont shift dynamic store up
6317: jsb gbcol # clear garbage left from compile
6318: tstl cpsts # skip if no listing of comp stats
6319: beqlu 0f
6320: jmp inix0
6321: 0:
6322: jsb prtpg # eject page
6323: #
6324: # PRINT COMPILE STATISTICS
6325: #
6326: movl dnamp,r6 # next available loc
6327: subl2 statb,r6 # minus start
6328: ashl $-2,r6,r6 # convert to words
6329: movl r6,r5 # convert to integer
6330: movl $encm1,r9 # point to /memory used (words)/
6331: jsb prtmi # print message
6332: movl dname,r6 # end of memory
6333: subl2 dnamp,r6 # minus next available loc
6334: ashl $-2,r6,r6 # convert to words
6335: movl r6,r5 # convert to integer
6336: movl $encm2,r9 # point to /memory available (words)/
6337: jsb prtmi # print line
6338: movl cmerc,r5 # get count of errors as integer
6339: movl $encm3,r9 # point to /compile errors/
6340: jsb prtmi # print it
6341: movl gbcnt,r5 # garbage collection count
6342: subl2 intv1,r5 # adjust for unavoidable collect
6343: movl $stpm5,r9 # point to /storage regenerations/
6344: jsb prtmi # print gbcol count
6345: jsb systm # get time
6346: subl2 timsx,r5 # get compilation time
6347: movl $encm4,r9 # point to compilation time (msec)/
6348: jsb prtmi # print message
6349: addl2 $num05,lstlc # bump line count
6350: tstl headp # no eject if nothing printed (sdg11)
6351: bnequ 0f
6352: jmp inix0
6353: 0:
6354: jsb prtpg # eject printer
6355: #page
6356: #
6357: # PREPARE NOW TO START EXECUTION
6358: #
6359: # SET DEFAULT INPUT RECORD LENGTH
6360: #
6361: inix0: cmpl cswin,$iniln # skip if not default -in72 used
6362: bgtru inix1
6363: movl $inils,cswin # else use default record length
6364: #
6365: # RESET TIMER
6366: #
6367: inix1: jsb systm # get time again
6368: movl r5,timsx # store for end run processing
6369: addl2 cswex,noxeq # add -noexecute flag
6370: tstl noxeq # jump if execution suppressed
6371: bnequ inix2
6372: clrl gbcnt # initialise collect count
6373: jsb sysbx # call before starting execution
6374: #
6375: # MERGE WHEN LISTING FILE SET FOR EXECUTION
6376: #
6377: iniy0: movl sp,headp # mark headers out regardless
6378: clrl -(sp) # set failure location on stack
6379: movl sp,flptr # save ptr to failure offset word
6380: movl r$cod,r9 # load ptr to entry code block
6381: movl $stgxt,stage # set stage for execute time
6382: movl cmpsn,pfnte # copy stmts compiled count in case
6383: jsb systm # time yet again
6384: movl r5,pfstm
6385: movl (r9),r11 # start xeq with first statement
6386: jmp (r11)
6387: #
6388: # HERE IF EXECUTION IS SUPPRESSED
6389: #
6390: inix2: jsb prtnl # print a blank line
6391: movl $encm5,r9 # point to /execution suppressed/
6392: jsb prtst # print string
6393: jsb prtnl # output line
6394: clrl r6 # set abend value to zero
6395: movl $nini9,r7 # set special code value
6396: jsb sysej # end of job, exit to system
6397: #title s p i t b o l -- snobol4 operator routines
6398: #
6399: # THIS SECTION INCLUDES ALL ROUTINES WHICH CAN BE ACCESSED
6400: # DIRECTLY FROM THE GENERATED CODE EXCEPT SYSTEM FUNCTIONS.
6401: #
6402: # ALL ROUTINES IN THIS SECTION START WITH A LABEL OF THE
6403: # FORM O$XXX WHERE XXX IS THREE LETTERS. THE GENERATED CODE
6404: # CONTAINS A POINTER TO THE APPROPRIATE ENTRY LABEL.
6405: #
6406: # SINCE THE GENERAL FORM OF THE GENERATED CODE CONSISTS OF
6407: # POINTERS TO BLOCKS WHOSE FIRST WORD IS THE ADDRESS OF THE
6408: # ACTUAL ENTRY POINT LABEL (O$XXX).
6409: #
6410: # THESE ROUTINES ARE IN ALPHABETICAL ORDER BY THEIR
6411: # ENTRY LABEL NAMES (I.E. BY THE XXX OF THE O$XXX NAME)
6412: #
6413: # THESE ROUTINES RECEIVE CONTROL AS FOLLOWS
6414: #
6415: # (CP) POINTER TO NEXT CODE WORD
6416: # (XS) CURRENT STACK POINTER
6417: #page
6418: #
6419: # BINARY PLUS (ADDITION)
6420: #
6421: o$add: # entry point
6422: jsb arith # fetch arithmetic operands
6423: .long er_001 # addition left operand is not numeric
6424: .long er_002 # addition right operand is not numeric
6425: .long oadd1 # jump if real operands
6426: #
6427: # HERE TO ADD TWO INTEGERS
6428: #
6429: addl2 4*icval(r10),r5 # add right operand to left
6430: bvs 0f
6431: jmp exint
6432: 0:
6433: jmp er_003 # addition caused integer overflow
6434: #
6435: # HERE TO ADD TWO REALS
6436: #
6437: oadd1: addf2 4*rcval(r10),r2 # add right operand to left
6438: bvs 0f
6439: jmp exrea
6440: 0:
6441: jmp er_261 # addition caused real overflow
6442: #page
6443: #
6444: # UNARY PLUS (AFFIRMATION)
6445: #
6446: o$aff: # entry point
6447: movl (sp)+,r9 # load operand
6448: jsb gtnum # convert to numeric
6449: .long er_004 # affirmation operand is not numeric
6450: jmp exixr # return if converted to numeric
6451: #page
6452: #
6453: # BINARY BAR (ALTERNATION)
6454: #
6455: o$alt: # entry point
6456: movl (sp)+,r9 # load right operand
6457: jsb gtpat # convert to pattern
6458: .long er_005 # alternation right operand is not pattern
6459: #
6460: # MERGE HERE FROM SPECIAL (LEFT ALTERNATION) CASE
6461: #
6462: oalt1: movl $p$alt,r7 # set pcode for alternative node
6463: jsb pbild # build alternative node
6464: movl r9,r10 # save address of alternative node
6465: movl (sp)+,r9 # load left operand
6466: jsb gtpat # convert to pattern
6467: .long er_006 # alternation left operand is not pattern
6468: cmpl r9,$p$alt # jump if left arg is alternation
6469: beqlu oalt2
6470: movl r9,4*pthen(r10) # set left operand as successor
6471: movl r10,r9 # move result to proper register
6472: jmp exixr # jump for next code word
6473: #
6474: # COME HERE IF LEFT ARGUMENT IS ITSELF AN ALTERNATION
6475: #
6476: # THE RESULT IS MORE EFFICIENT IF WE MAKE THE REPLACEMENT
6477: #
6478: # (A / B) / C = A / (B / C)
6479: #
6480: oalt2: movl 4*parm1(r9),4*pthen(r10) # build the (b / c) node
6481: movl 4*pthen(r9),-(sp)# set a as new left arg
6482: movl r10,r9 # set (b / c) as new right arg
6483: jmp oalt1 # merge back to build a / (b / c)
6484: #page
6485: #
6486: # ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY NAME)
6487: #
6488: o$amn: # entry point
6489: movl (r3)+,r9 # load number of subscripts
6490: movl r9,r7 # set flag for by name
6491: jmp arref # jump to array reference routine
6492: #page
6493: #
6494: # ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY VALUE)
6495: #
6496: o$amv: # entry point
6497: movl (r3)+,r9 # load number of subscripts
6498: clrl r7 # set flag for by value
6499: jmp arref # jump to array reference routine
6500: #page
6501: #
6502: # ARRAY REFERENCE (ONE SUBSCRIPT, BY NAME)
6503: #
6504: o$aon: # entry point
6505: movl (sp),r9 # load subscript value
6506: movl 4*1(sp),r10 # load array value
6507: movl (r10),r6 # load first word of array operand
6508: cmpl r6,$b$vct # jump if vector reference
6509: beqlu oaon2
6510: cmpl r6,$b$tbt # jump if table reference
6511: beqlu oaon3
6512: #
6513: # HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
6514: #
6515: oaon1: movl $num01,r9 # set number of subscripts to one
6516: movl r9,r7 # set flag for by name
6517: jmp arref # jump to array reference routine
6518: #
6519: # HERE IF WE HAVE A VECTOR REFERENCE
6520: #
6521: oaon2: cmpl (r9),$b$icl # use long routine if not integer
6522: bnequ oaon1
6523: movl 4*icval(r9),r5 # load integer subscript value
6524: movl r5,r6 # copy as address int, fail if ovflo
6525: bgeq 0f
6526: jmp exfal
6527: 0:
6528: tstl r6 # fail if zero
6529: bnequ 0f
6530: jmp exfal
6531: 0:
6532: addl2 $vcvlb,r6 # compute offset in words
6533: moval 0[r6],r6 # convert to bytes
6534: movl r6,(sp) # complete name on stack
6535: cmpl r6,4*vclen(r10) # exit if subscript not too large
6536: bgequ 0f
6537: jmp exits
6538: 0:
6539: jmp exfal # else fail
6540: #
6541: # HERE FOR TABLE REFERENCE
6542: #
6543: oaon3: movl sp,r7 # set flag for name reference
6544: jsb tfind # locate/create table element
6545: .long exfal # fail if access fails
6546: movl r10,4*1(sp) # store name base on stack
6547: movl r6,(sp) # store name offset on stack
6548: jmp exits # exit with result on stack
6549: #page
6550: #
6551: # ARRAY REFERENCE (ONE SUBSCRIPT, BY VALUE)
6552: #
6553: o$aov: # entry point
6554: movl (sp)+,r9 # load subscript value
6555: movl (sp)+,r10 # load array value
6556: movl (r10),r6 # load first word of array operand
6557: cmpl r6,$b$vct # jump if vector reference
6558: beqlu oaov2
6559: cmpl r6,$b$tbt # jump if table reference
6560: beqlu oaov3
6561: #
6562: # HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
6563: #
6564: oaov1: movl r10,-(sp) # restack array value
6565: movl r9,-(sp) # restack subscript
6566: movl $num01,r9 # set number of subscripts to one
6567: clrl r7 # set flag for value call
6568: jmp arref # jump to array reference routine
6569: #
6570: # HERE IF WE HAVE A VECTOR REFERENCE
6571: #
6572: oaov2: cmpl (r9),$b$icl # use long routine if not integer
6573: bnequ oaov1
6574: movl 4*icval(r9),r5 # load integer subscript value
6575: movl r5,r6 # move as one word int, fail if ovflo
6576: bgeq 0f
6577: jmp exfal
6578: 0:
6579: tstl r6 # fail if zero
6580: bnequ 0f
6581: jmp exfal
6582: 0:
6583: addl2 $vcvlb,r6 # compute offset in words
6584: moval 0[r6],r6 # convert to bytes
6585: cmpl r6,4*vclen(r10) # fail if subscript too large
6586: blssu 0f
6587: jmp exfal
6588: 0:
6589: jsb acess # access value
6590: .long exfal # fail if access fails
6591: jmp exixr # else return value to caller
6592: #
6593: # HERE FOR TABLE REFERENCE BY VALUE
6594: #
6595: oaov3: clrl r7 # set flag for value reference
6596: jsb tfind # call table search routine
6597: .long exfal # fail if access fails
6598: jmp exixr # exit with result in xr
6599: #page
6600: #
6601: # ASSIGNMENT
6602: #
6603: o$ass: # entry point
6604: #
6605: # O$RPL (PATTERN REPLACEMENT) MERGES HERE
6606: #
6607: oass0: movl (sp)+,r7 # load value to be assigned
6608: movl (sp)+,r6 # load name offset
6609: movl (sp),r10 # load name base
6610: movl r7,(sp) # store assigned value as result
6611: jsb asign # perform assignment
6612: .long exfal # fail if assignment fails
6613: jmp exits # exit with result on stack
6614: #page
6615: #
6616: # COMPILATION ERROR
6617: #
6618: o$cer: # entry point
6619: jmp er_007 # compilation error encountered during execution
6620: #page
6621: #
6622: # UNARY AT (CURSOR ASSIGNMENT)
6623: #
6624: o$cas: # entry point
6625: movl (sp)+,r8 # load name offset (parm2)
6626: movl (sp)+,r9 # load name base (parm1)
6627: movl $p$cas,r7 # set pcode for cursor assignment
6628: jsb pbild # build node
6629: jmp exixr # jump for next code word
6630: #page
6631: #
6632: # CONCATENATION
6633: #
6634: o$cnc: # entry point
6635: movl (sp),r9 # load right argument
6636: cmpl r9,$nulls # jump if right arg is null
6637: bnequ 0f
6638: jmp ocnc3
6639: 0:
6640: movl 4*1(sp),r10 # load left argument
6641: cmpl r10,$nulls # jump if left argument is null
6642: bnequ 0f
6643: jmp ocnc4
6644: 0:
6645: movl $b$scl,r6 # get constant to test for string
6646: cmpl r6,(r10) # jump if left arg not a string
6647: beqlu 0f
6648: jmp ocnc2
6649: 0:
6650: cmpl r6,(r9) # jump if right arg not a string
6651: beqlu 0f
6652: jmp ocnc2
6653: 0:
6654: #
6655: # MERGE HERE TO CONCATENATE TWO STRINGS
6656: #
6657: ocnc1: movl 4*sclen(r10),r6 # load left argument length
6658: addl2 4*sclen(r9),r6 # compute result length
6659: jsb alocs # allocate scblk for result
6660: movl r9,4*1(sp) # store result ptr over left argument
6661: movab cfp$f(r9),r9 # prepare to store chars of result
6662: movl 4*sclen(r10),r6 # get number of chars in left arg
6663: movab cfp$f(r10),r10 # prepare to load left arg chars
6664: jsb sbmvc # move characters of left argument
6665: movl (sp)+,r10 # load right arg pointer, pop stack
6666: movl 4*sclen(r10),r6 # load number of chars in right arg
6667: movab cfp$f(r10),r10 # prepare to load right arg chars
6668: jsb sbmvc # move characters of right argument
6669: jmp exits # exit with result on stack
6670: #
6671: # COME HERE IF ARGUMENTS ARE NOT BOTH STRINGS
6672: #
6673: ocnc2: jsb gtstg # convert right arg to string
6674: .long ocnc5 # jump if right arg is not string
6675: movl r9,r10 # save right arg ptr
6676: jsb gtstg # convert left arg to string
6677: .long ocnc6 # jump if left arg is not a string
6678: movl r9,-(sp) # stack left argument
6679: movl r10,-(sp) # stack right argument
6680: movl r9,r10 # move left arg to proper reg
6681: movl (sp),r9 # move right arg to proper reg
6682: jmp ocnc1 # merge back to concatenate strings
6683: #page
6684: #
6685: # CONCATENATION (CONTINUED)
6686: #
6687: # COME HERE FOR NULL RIGHT ARGUMENT
6688: #
6689: ocnc3: addl2 $4,sp # remove right arg from stack
6690: jmp exits # return with left argument on stack
6691: #
6692: # HERE FOR NULL LEFT ARGUMENT
6693: #
6694: ocnc4: addl2 $4,sp # unstack one argument
6695: movl r9,(sp) # store right argument
6696: jmp exits # exit with result on stack
6697: #
6698: # HERE IF RIGHT ARGUMENT IS NOT A STRING
6699: #
6700: ocnc5: movl r9,r10 # move right argument ptr
6701: movl (sp)+,r9 # load left arg pointer
6702: #
6703: # MERGE HERE WHEN LEFT ARGUMENT IS NOT A STRING
6704: #
6705: ocnc6: jsb gtpat # convert left arg to pattern
6706: .long er_008 # concatenation left opnd is not string or pattern
6707: movl r9,-(sp) # save result on stack
6708: movl r10,r9 # point to right operand
6709: jsb gtpat # convert to pattern
6710: .long er_009 # concatenation right opd is not string or pattern
6711: movl r9,r10 # move for pconc
6712: movl (sp)+,r9 # reload left operand ptr
6713: jsb pconc # concatenate patterns
6714: jmp exixr # exit with result in xr
6715: #page
6716: #
6717: # COMPLEMENTATION
6718: #
6719: o$com: # entry point
6720: movl (sp)+,r9 # load operand
6721: movl (r9),r6 # load type word
6722: #
6723: # MERGE BACK HERE AFTER CONVERSION
6724: #
6725: ocom1: cmpl r6,$b$icl # jump if integer
6726: beqlu ocom2
6727: cmpl r6,$b$rcl # jump if real
6728: beqlu ocom3
6729: jsb gtnum # else convert to numeric
6730: .long er_010 # complementation operand is not numeric
6731: jmp ocom1 # back to check cases
6732: #
6733: # HERE TO COMPLEMENT INTEGER
6734: #
6735: ocom2: movl 4*icval(r9),r5 # load integer value
6736: mnegl r5,r5 # negate
6737: bvs 0f
6738: jmp exint
6739: 0:
6740: jmp er_011 # complementation caused integer overflow
6741: #
6742: # HERE TO COMPLEMENT REAL
6743: #
6744: ocom3: movf 4*rcval(r9),r2 # load real value
6745: mnegf r2,r2 # negate
6746: jmp exrea # return real result
6747: #page
6748: #
6749: # BINARY SLASH (DIVISION)
6750: #
6751: o$dvd: # entry point
6752: jsb arith # fetch arithmetic operands
6753: .long er_012 # division left operand is not numeric
6754: .long er_013 # division right operand is not numeric
6755: .long odvd2 # jump if real operands
6756: #
6757: # HERE TO DIVIDE TWO INTEGERS
6758: #
6759: divl2 4*icval(r10),r5 # divide left operand by right
6760: bvs 0f
6761: jmp exint
6762: 0:
6763: jmp er_014 # division caused integer overflow
6764: #
6765: # HERE TO DIVIDE TWO REALS
6766: #
6767: odvd2: divf2 4*rcval(r10),r2 # divide left operand by right
6768: bvs 0f
6769: jmp exrea
6770: 0:
6771: jmp er_262 # division caused real overflow
6772: #page
6773: #
6774: # EXPONENTIATION
6775: #
6776: o$exp: # entry point
6777: movl (sp)+,r9 # load exponent
6778: jsb gtnum # convert to number
6779: .long er_015 # exponentiation right operand is not numeric
6780: cmpl r6,$b$icl # jump if real
6781: beqlu 0f
6782: jmp oexp7
6783: 0:
6784: movl r9,r10 # move exponent
6785: movl (sp)+,r9 # load base
6786: jsb gtnum # convert to numeric
6787: .long er_016 # exponentiation left operand is not numeric
6788: movl 4*icval(r10),r5 # load exponent
6789: tstl r5 # error if negative exponent
6790: bgeq 0f
6791: jmp oexp8
6792: 0:
6793: cmpl r6,$b$rcl # jump if base is real
6794: beqlu oexp3
6795: #
6796: # HERE TO EXPONENTIATE AN INTEGER
6797: #
6798: movl r5,r6 # convert exponent to 1 word integer
6799: bgeq 0f
6800: jmp oexp2
6801: 0:
6802: # set loop counter
6803: movl intv1,r5 # load initial value of 1
6804: tstl r6 # jump if non-zero exponent
6805: bnequ oexp1
6806: tstl r5 # give zero as result for nonzero**0
6807: beql 0f
6808: jmp exint
6809: 0:
6810: jmp oexp4 # else error of 0**0
6811: #
6812: # LOOP TO PERFORM EXPONENTIATION
6813: #
6814: oexp1: mull2 4*icval(r9),r5 # multiply by base
6815: bvs oexp2
6816: sobgtr r6,oexp1 # loop back till computation complete
6817: jmp exint # then return integer result
6818: #
6819: # HERE IF INTEGER OVERFLOW
6820: #
6821: oexp2: jmp er_017 # exponentiation caused integer overflow
6822: #page
6823: #
6824: # EXPONENTIATION (CONTINUED)
6825: #
6826: # HERE TO EXPONENTIATE A REAL
6827: #
6828: oexp3: movl r5,r6 # convert exponent to one word
6829: bgeq 0f
6830: jmp oexp6
6831: 0:
6832: # set loop counter
6833: movf reav1,r2 # load 1.0 as initial value
6834: tstl r6 # jump if non-zero exponent
6835: bnequ oexp5
6836: tstf r2 # return 1.0 if nonzero**zero
6837: beql 0f
6838: jmp exrea
6839: 0:
6840: #
6841: # HERE FOR ERROR OF 0**0 OR 0.0**0
6842: #
6843: oexp4: jmp er_018 # exponentiation result is undefined
6844: #
6845: # LOOP TO PERFORM EXPONENTIATION
6846: #
6847: oexp5: mulf2 4*rcval(r9),r2 # multiply by base
6848: bvs oexp6
6849: sobgtr r6,oexp5 # loop till computation complete
6850: jmp exrea # then return real result
6851: #
6852: # HERE IF REAL OVERFLOW
6853: #
6854: oexp6: jmp er_266 # exponentiation caused real overflow
6855: #
6856: # HERE IF REAL EXPONENT
6857: #
6858: oexp7: jmp er_267 # exponentiation right operand is real not integer
6859: #
6860: # HERE FOR NEGATIVE EXPONENT
6861: #
6862: oexp8: jmp er_019 # exponentiation right operand is negative
6863: #page
6864: #
6865: # FAILURE IN EXPRESSION EVALUATION
6866: #
6867: # THIS ENTRY POINT IS USED IF THE EVALUATION OF AN
6868: # EXPRESSION, INITIATED BY THE EVALX PROCEDURE, FAILS.
6869: # CONTROL IS RETURNED TO AN APPROPRIATE POINT IN EVALX.
6870: #
6871: o$fex: # entry point
6872: jmp evlx6 # jump to failure loc in evalx
6873: #page
6874: #
6875: # FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO
6876: #
6877: o$fif: # entry point
6878: jmp er_020 # goto evaluation failure
6879: #page
6880: #
6881: # FUNCTION CALL (MORE THAN ONE ARGUMENT)
6882: #
6883: o$fnc: # entry point
6884: movl (r3)+,r6 # load number of arguments
6885: movl (r3)+,r9 # load function vrblk pointer
6886: movl 4*vrfnc(r9),r10 # load function pointer
6887: cmpl r6,4*fargs(r10) # use central routine if wrong num
6888: beqlu 0f
6889: jmp cfunc
6890: 0:
6891: movl (r10),r11 # jump to function if arg count ok
6892: jmp (r11)
6893: #page
6894: #
6895: # FUNCTION NAME ERROR
6896: #
6897: o$fne: # entry point
6898: movl (r3)+,r6 # get next code word
6899: cmpl r6,$ornm$ # fail if not evaluating expression
6900: bnequ ofne1
6901: tstl 4*2(sp) # ok if expr. was wanted by value
6902: bnequ 0f
6903: jmp evlx3
6904: 0:
6905: #
6906: # HERE FOR ERROR
6907: #
6908: ofne1: jmp er_021 # function called by name returned a value
6909: #page
6910: #
6911: # FUNCTION CALL (SINGLE ARGUMENT)
6912: #
6913: o$fns: # entry point
6914: movl (r3)+,r9 # load function vrblk pointer
6915: movl $num01,r6 # set number of arguments to one
6916: movl 4*vrfnc(r9),r10 # load function pointer
6917: cmpl r6,4*fargs(r10) # use central routine if wrong num
6918: beqlu 0f
6919: jmp cfunc
6920: 0:
6921: movl (r10),r11 # jump to function if arg count ok
6922: jmp (r11)
6923: #page
6924: # CALL TO UNDEFINED FUNCTION
6925: #
6926: o$fun: # entry point
6927: jmp er_022 # undefined function called
6928: #page
6929: #
6930: # EXECUTE COMPLEX GOTO
6931: #
6932: o$goc: # entry point
6933: movl 4*1(sp),r9 # load name base pointer
6934: cmpl r9,state # jump if not natural variable
6935: bgequ ogoc1
6936: addl2 $4*vrtra,r9 # else point to vrtra field
6937: movl (r9),r11 # and jump through it
6938: jmp (r11)
6939: #
6940: # HERE IF GOTO OPERAND IS NOT NATURAL VARIABLE
6941: #
6942: ogoc1: jmp er_023 # goto operand is not a natural variable
6943: #page
6944: #
6945: # EXECUTE DIRECT GOTO
6946: #
6947: o$god: # entry point
6948: movl (sp),r9 # load operand
6949: movl (r9),r6 # load first word
6950: cmpl r6,$b$cds # jump if code block to code routine
6951: bnequ 0f
6952: jmp bcds0
6953: 0:
6954: cmpl r6,$b$cdc # jump if code block to code routine
6955: bnequ 0f
6956: jmp bcdc0
6957: 0:
6958: jmp er_024 # goto operand in direct goto is not code
6959: #page
6960: #
6961: # SET GOTO FAILURE TRAP
6962: #
6963: # THIS ROUTINE IS EXECUTED AT THE START OF A COMPLEX OR
6964: # DIRECT FAILURE GOTO TO TRAP A SUBSEQUENT FAIL (SEE EXFAL)
6965: #
6966: o$gof: # entry point
6967: movl flptr,r9 # point to fail offset on stack
6968: addl2 $4,(r9) # point failure to o$fif word
6969: tstl (r3)+ # point to next code word
6970: jmp exits # exit to continue
6971: #page
6972: #
6973: # BINARY DOLLAR (IMMEDIATE ASSIGNMENT)
6974: #
6975: # THE PATTERN BUILT BY BINARY DOLLAR IS A COMPOUND PATTERN.
6976: # SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR
6977: # DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED.
6978: #
6979: o$ima: # entry point
6980: movl $p$imc,r7 # set pcode for last node
6981: movl (sp)+,r8 # pop name offset (parm2)
6982: movl (sp)+,r9 # pop name base (parm1)
6983: jsb pbild # build p$imc node
6984: movl r9,r10 # save ptr to node
6985: movl (sp),r9 # load left argument
6986: jsb gtpat # convert to pattern
6987: .long er_025 # immediate assignment left operand is not pattern
6988: movl r9,(sp) # save ptr to left operand pattern
6989: movl $p$ima,r7 # set pcode for first node
6990: jsb pbild # build p$ima node
6991: movl (sp)+,4*pthen(r9)# set left operand as p$ima successor
6992: jsb pconc # concatenate to form final pattern
6993: jmp exixr # all done
6994: #page
6995: #
6996: # INDIRECTION (BY NAME)
6997: #
6998: o$inn: # entry point
6999: movl sp,r7 # set flag for result by name
7000: jmp indir # jump to common routine
7001: #page
7002: #
7003: # INTERROGATION
7004: #
7005: o$int: # entry point
7006: movl $nulls,(sp) # replace operand with null
7007: jmp exits # exit for next code word
7008: #page
7009: #
7010: # INDIRECTION (BY VALUE)
7011: #
7012: o$inv: # entry point
7013: clrl r7 # set flag for by value
7014: jmp indir # jump to common routine
7015: #page
7016: #
7017: # KEYWORD REFERENCE (BY NAME)
7018: #
7019: o$kwn: # entry point
7020: jsb kwnam # get keyword name
7021: jmp exnam # exit with result name
7022: #page
7023: #
7024: # KEYWORD REFERENCE (BY VALUE)
7025: #
7026: o$kwv: # entry point
7027: jsb kwnam # get keyword name
7028: movl r9,dnamp # delete kvblk
7029: jsb acess # access value
7030: .long exnul # dummy (unused) failure return
7031: jmp exixr # jump with value in xr
7032: #page
7033: #
7034: # LOAD EXPRESSION BY NAME
7035: #
7036: o$lex: # entry point
7037: movl $4*evsi$,r6 # set size of evblk
7038: jsb alloc # allocate space for evblk
7039: movl $b$evt,(r9) # set type word
7040: movl $trbev,4*evvar(r9) # set dummy trblk pointer
7041: movl (r3)+,r6 # load exblk pointer
7042: movl r6,4*evexp(r9) # set exblk pointer
7043: movl r9,r10 # move name base to proper reg
7044: movl $4*evvar,r6 # set name offset = zero
7045: jmp exnam # exit with name in (xl,wa)
7046: #page
7047: #
7048: # LOAD PATTERN VALUE
7049: #
7050: o$lpt: # entry point
7051: movl (r3)+,r9 # load pattern pointer
7052: jmp exixr # stack ptr and obey next code word
7053: #page
7054: #
7055: # LOAD VARIABLE NAME
7056: #
7057: o$lvn: # entry point
7058: movl (r3)+,r6 # load vrblk pointer
7059: movl r6,-(sp) # stack vrblk ptr (name base)
7060: movl $4*vrval,-(sp) # stack name offset
7061: jmp exits # exit with result on stack
7062: #page
7063: #
7064: # BINARY ASTERISK (MULTIPLICATION)
7065: #
7066: o$mlt: # entry point
7067: jsb arith # fetch arithmetic operands
7068: .long er_026 # multiplication left operand is not numeric
7069: .long er_027 # multiplication right operand is not numeric
7070: .long omlt1 # jump if real operands
7071: #
7072: # HERE TO MULTIPLY TWO INTEGERS
7073: #
7074: mull2 4*icval(r10),r5 # multiply left operand by right
7075: bvs 0f
7076: jmp exint
7077: 0:
7078: jmp er_028 # multiplication caused integer overflow
7079: #
7080: # HERE TO MULTIPLY TWO REALS
7081: #
7082: omlt1: mulf2 4*rcval(r10),r2 # multiply left operand by right
7083: bvs 0f
7084: jmp exrea
7085: 0:
7086: jmp er_263 # multiplication caused real overflow
7087: #page
7088: #
7089: # NAME REFERENCE
7090: #
7091: o$nam: # entry point
7092: movl $4*nmsi$,r6 # set length of nmblk
7093: jsb alloc # allocate nmblk
7094: movl $b$nml,(r9) # set name block code
7095: movl (sp)+,4*nmofs(r9)# set name offset from operand
7096: movl (sp)+,4*nmbas(r9)# set name base from operand
7097: jmp exixr # exit with result in xr
7098: #page
7099: #
7100: # NEGATION
7101: #
7102: # INITIAL ENTRY
7103: #
7104: o$nta: # entry point
7105: movl (r3)+,r6 # load new failure offset
7106: movl flptr,-(sp) # stack old failure pointer
7107: movl r6,-(sp) # stack new failure offset
7108: movl sp,flptr # set new failure pointer
7109: jmp exits # jump to continue execution
7110: #
7111: # ENTRY AFTER SUCCESSFUL EVALUATION OF OPERAND
7112: #
7113: o$ntb: # entry point
7114: movl 4*2(sp),flptr # restore old failure pointer
7115: jmp exfal # and fail
7116: #
7117: # ENTRY FOR FAILURE DURING OPERAND EVALUATION
7118: #
7119: o$ntc: # entry point
7120: addl2 $4,sp # pop failure offset
7121: movl (sp)+,flptr # restore old failure pointer
7122: jmp exnul # exit giving null result
7123: #page
7124: #
7125: # USE OF UNDEFINED OPERATOR
7126: #
7127: o$oun: # entry point
7128: jmp er_029 # undefined operator referenced
7129: #page
7130: #
7131: # BINARY DOT (PATTERN ASSIGNMENT)
7132: #
7133: # THE PATTERN BUILT BY BINARY DOT IS A COMPOUND PATTERN.
7134: # SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR
7135: # DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED.
7136: #
7137: o$pas: # entry point
7138: movl $p$pac,r7 # load pcode for p$pac node
7139: movl (sp)+,r8 # load name offset (parm2)
7140: movl (sp)+,r9 # load name base (parm1)
7141: jsb pbild # build p$pac node
7142: movl r9,r10 # save ptr to node
7143: movl (sp),r9 # load left operand
7144: jsb gtpat # convert to pattern
7145: .long er_030 # pattern assignment left operand is not pattern
7146: movl r9,(sp) # save ptr to left operand pattern
7147: movl $p$paa,r7 # set pcode for p$paa node
7148: jsb pbild # build p$paa node
7149: movl (sp)+,4*pthen(r9)# set left operand as p$paa successor
7150: jsb pconc # concatenate to form final pattern
7151: jmp exixr # jump for next code word
7152: #page
7153: #
7154: # PATTERN MATCH (BY NAME, FOR REPLACEMENT)
7155: #
7156: o$pmn: # entry point
7157: clrl r7 # set type code for match by name
7158: jmp match # jump to routine to start match
7159: #page
7160: #
7161: # PATTERN MATCH (STATEMENT)
7162: #
7163: # O$PMS IS USED IN PLACE OF O$PMV WHEN THE PATTERN MATCH
7164: # OCCURS AT THE OUTER (STATEMENT) LEVEL SINCE IN THIS
7165: # CASE THE SUBSTRING VALUE NEED NOT BE CONSTRUCTED.
7166: #
7167: o$pms: # entry point
7168: movl $num02,r7 # set flag for statement to match
7169: jmp match # jump to routine to start match
7170: #page
7171: #
7172: # PATTERN MATCH (BY VALUE)
7173: #
7174: o$pmv: # entry point
7175: movl $num01,r7 # set type code for value match
7176: jmp match # jump to routine to start match
7177: #page
7178: #
7179: # POP TOP ITEM ON STACK
7180: #
7181: o$pop: # entry point
7182: addl2 $4,sp # pop top stack entry
7183: jmp exits # obey next code word
7184: #page
7185: #
7186: # TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT)
7187: #
7188: o$stp: # entry point
7189: jmp lend0 # jump to end circuit
7190: #page
7191: #
7192: # RETURN NAME FROM EXPRESSION
7193: # THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN
7194: # EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS
7195: # A NAME. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX.
7196: #
7197: o$rnm: # entry point
7198: jmp evlx4 # return to evalx procedure
7199: #page
7200: #
7201: # PATTERN REPLACEMENT
7202: #
7203: # WHEN THIS ROUTINE GETS CONTROL, THE FOLLOWING STACK
7204: # ENTRIES HAVE BEEN MADE (SEE END OF MATCH ROUTINE P$NTH)
7205: #
7206: # SUBJECT NAME BASE
7207: # SUBJECT NAME OFFSET
7208: # INITIAL CURSOR VALUE
7209: # FINAL CURSOR VALUE
7210: # SUBJECT POINTER
7211: # (XS) ---------------- REPLACEMENT VALUE
7212: #
7213: o$rpl: # entry point
7214: jsb gtstg # convert replacement val to string
7215: .long er_031 # pattern replacement right operand is not string
7216: #
7217: # GET RESULT LENGTH AND ALLOCATE RESULT SCBLK
7218: #
7219: movl (sp),r10 # load subject string pointer
7220: cmpl (r10),$b$bct # branch if buffer assignment
7221: bnequ 0f
7222: jmp orpl4
7223: 0:
7224: addl2 4*sclen(r10),r6 # add subject string length
7225: addl2 4*2(sp),r6 # add starting cursor
7226: subl2 4*1(sp),r6 # minus final cursor = total length
7227: tstl r6 # jump if result is null
7228: bnequ 0f
7229: jmp orpl3
7230: 0:
7231: movl r9,-(sp) # restack replacement string
7232: jsb alocs # allocate scblk for result
7233: movl 4*3(sp),r6 # get initial cursor (part 1 len)
7234: movl r9,4*3(sp) # stack result pointer
7235: movab cfp$f(r9),r9 # point to characters of result
7236: #
7237: # MOVE PART 1 (START OF SUBJECT) TO RESULT
7238: #
7239: tstl r6 # jump if first part is null
7240: beqlu orpl1
7241: movl 4*1(sp),r10 # else point to subject string
7242: movab cfp$f(r10),r10 # point to subject string chars
7243: jsb sbmvc # move first part to result
7244: #page
7245: # PATTERN REPLACEMENT (CONTINUED)
7246: #
7247: # NOW MOVE IN REPLACEMENT VALUE
7248: #
7249: orpl1: movl (sp)+,r10 # load replacement string, pop
7250: movl 4*sclen(r10),r6 # load length
7251: tstl r6 # jump if null replacement
7252: beqlu orpl2
7253: movab cfp$f(r10),r10 # else point to chars of replacement
7254: jsb sbmvc # move in chars (part 2)
7255: #
7256: # NOW MOVE IN REMAINDER OF STRING (PART 3)
7257: #
7258: orpl2: movl (sp)+,r10 # load subject string pointer, pop
7259: movl (sp)+,r8 # load final cursor, pop
7260: movl 4*sclen(r10),r6 # load subject string length
7261: subl2 r8,r6 # minus final cursor = part 3 length
7262: tstl r6 # jump to assign if part 3 is null
7263: bnequ 0f
7264: jmp oass0
7265: 0:
7266: movab cfp$f(r10)[r8],r10 # else point to last part of string
7267: jsb sbmvc # move part 3 to result
7268: jmp oass0 # jump to perform assignment
7269: #
7270: # HERE IF RESULT IS NULL
7271: #
7272: orpl3: addl2 $4*num02,sp # pop subject str ptr, final cursor
7273: movl $nulls,(sp) # set null result
7274: jmp oass0 # jump to assign null value
7275: #
7276: # HERE FOR BUFFER SUBSTRING ASSIGNMENT
7277: #
7278: orpl4: movl r9,r10 # copy scblk replacement ptr
7279: movl (sp)+,r9 # unstack bcblk ptr
7280: movl (sp)+,r7 # get final cursor value
7281: movl (sp)+,r6 # get initial cursor
7282: subl2 r6,r7 # get length in wb
7283: addl2 $4*num02,sp # get rid of name base/offset
7284: jsb insbf # insert substring
7285: .long invalid$ # convert fail impossible
7286: .long exfal # fail if insert fails
7287: jmp exnul # else null result
7288: #page
7289: #
7290: # RETURN VALUE FROM EXPRESSION
7291: #
7292: # THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN
7293: # EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS
7294: # A VALUE. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX
7295: #
7296: o$rvl: # entry point
7297: jmp evlx3 # return to evalx procedure
7298: #page
7299: #
7300: # SELECTION
7301: #
7302: # INITIAL ENTRY
7303: #
7304: o$sla: # entry point
7305: movl (r3)+,r6 # load new failure offset
7306: movl flptr,-(sp) # stack old failure pointer
7307: movl r6,-(sp) # stack new failure offset
7308: movl sp,flptr # set new failure pointer
7309: jmp exits # jump to execute first alternative
7310: #
7311: # ENTRY AFTER SUCCESSFUL EVALUATION OF ALTERNATIVE
7312: #
7313: o$slb: # entry point
7314: movl (sp)+,r9 # load result
7315: addl2 $4,sp # pop fail offset
7316: movl (sp),flptr # restore old failure pointer
7317: movl r9,(sp) # restack result
7318: movl (r3)+,r6 # load new code offset
7319: addl2 r$cod,r6 # point to absolute code location
7320: movl r6,r3 # set new code pointer
7321: jmp exits # jump to continue past selection
7322: #
7323: # ENTRY AT START OF SUBSEQUENT ALTERNATIVES
7324: #
7325: o$slc: # entry point
7326: movl (r3)+,r6 # load new fail offset
7327: movl r6,(sp) # store new fail offset
7328: jmp exits # jump to execute next alternative
7329: #
7330: # ENTRY AT START OF LAST ALTERNATIVE
7331: #
7332: o$sld: # entry point
7333: addl2 $4,sp # pop failure offset
7334: movl (sp)+,flptr # restore old failure pointer
7335: jmp exits # jump to execute last alternative
7336: #page
7337: #
7338: # BINARY MINUS (SUBTRACTION)
7339: #
7340: o$sub: # entry point
7341: jsb arith # fetch arithmetic operands
7342: .long er_032 # subtraction left operand is not numeric
7343: .long er_033 # subtraction right operand is not numeric
7344: .long osub1 # jump if real operands
7345: #
7346: # HERE TO SUBTRACT TWO INTEGERS
7347: #
7348: subl2 4*icval(r10),r5 # subtract right operand from left
7349: bvs 0f
7350: jmp exint
7351: 0:
7352: jmp er_034 # subtraction caused integer overflow
7353: #
7354: # HERE TO SUBTRACT TWO REALS
7355: #
7356: osub1: subf2 4*rcval(r10),r2 # subtract right operand from left
7357: bvs 0f
7358: jmp exrea
7359: 0:
7360: jmp er_264 # subtraction caused real overflow
7361: #page
7362: #
7363: # DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE
7364: #
7365: o$txr: # entry point
7366: jmp trxq1 # jump into trxeq procedure
7367: #page
7368: #
7369: # UNEXPECTED FAILURE
7370: #
7371: # NOTE THAT IF A SETEXIT TRAP IS OPERATING THEN
7372: # TRANSFER TO SYSTEM LABEL CONTINUE
7373: # WILL RESULT IN LOOPING HERE. DIFFICULT TO AVOID EXCEPT
7374: # WITH A CONSIDERABLE OVERHEAD WHICH IS NOT WORTHWHILE OR
7375: # ELSE BY A TECHNIQUE SUCH AS SETTING KVERL TO ZERO.
7376: #
7377: o$unf: # entry point
7378: jmp er_035 # unexpected failure in -nofail mode
7379: #title s p i t b o l -- snobol4 builtin label routines
7380: #
7381: # THE FOLLOWING SECTION CONTAINS THE ROUTINES FOR LABELS
7382: # WHICH HAVE A PREDEFINED MEANING IN SNOBOL4.
7383: #
7384: # CONTROL IS PASSED DIRECTLY TO THE LABEL NAME ENTRY POINT.
7385: #
7386: # ENTRY NAMES ARE OF THE FORM L$XXX WHERE XXX IS THE THREE
7387: # LETTER VARIABLE NAME IDENTIFIER.
7388: #
7389: # ENTRIES ARE IN ALPHABETICAL ORDER
7390: #page
7391: #
7392: # ABORT
7393: #
7394: l$abo: # entry point
7395: #
7396: # MERGE HERE IF EXECUTION TERMINATES IN ERROR
7397: #
7398: labo1: movl kvert,r6 # load error code
7399: tstl r6 # jump if no error has occured
7400: beqlu labo2
7401: jsb sysax # call after execution proc (reg04)
7402: jsb prtpg # else eject printer
7403: jsb ermsg # print error message
7404: clrl r9 # indicate no message to print
7405: jmp stopr # jump to routine to stop run
7406: #
7407: # HERE IF NO ERROR HAD OCCURED
7408: #
7409: labo2: jmp er_036 # goto abort with no preceding error
7410: #page
7411: #
7412: # CONTINUE
7413: #
7414: l$cnt: # entry point
7415: #
7416: # MERGE HERE AFTER EXECUTION ERROR
7417: #
7418: lcnt1: movl r$cnt,r9 # load continuation code block ptr
7419: tstl r9 # jump if no previous error
7420: beqlu lcnt2
7421: clrl r$cnt # clear flag
7422: movl r9,r$cod # else store as new code block ptr
7423: addl2 stxof,r9 # add failure offset
7424: movl r9,r3 # load code pointer
7425: movl flptr,sp # reset stack pointer
7426: jmp exits # jump to take indicated failure
7427: #
7428: # HERE IF NO PREVIOUS ERROR
7429: #
7430: lcnt2: jmp er_037 # goto continue with no preceding error
7431: #page
7432: #
7433: # END
7434: #
7435: l$end: # entry point
7436: #
7437: # MERGE HERE FROM END CODE CIRCUIT
7438: #
7439: lend0: movl $endms,r9 # point to message /normal term../
7440: jmp stopr # jump to routine to stop run
7441: #page
7442: #
7443: # FRETURN
7444: #
7445: l$frt: # entry point
7446: movl $scfrt,r6 # point to string /freturn/
7447: jmp retrn # jump to common return routine
7448: #page
7449: #
7450: # NRETURN
7451: #
7452: l$nrt: # entry point
7453: movl $scnrt,r6 # point to string /nreturn/
7454: jmp retrn # jump to common return routine
7455: #page
7456: #
7457: # RETURN
7458: #
7459: l$rtn: # entry point
7460: movl $scrtn,r6 # point to string /return/
7461: jmp retrn # jump to common return routine
7462: #page
7463: #
7464: # UNDEFINED LABEL
7465: #
7466: l$und: # entry point
7467: jmp er_038 # goto undefined label
7468: #title s p i t b o l -- block action routines
7469: #
7470: # THE FIRST WORD OF EVERY BLOCK IN DYNAMIC STORAGE AND THE
7471: # VRGET, VRSTO AND VRTRA FIELDS OF A VRBLK CONTAIN A
7472: # POINTER TO AN ENTRY POINT IN THE PROGRAM. ALL SUCH ENTRY
7473: # POINTS ARE IN THE FOLLOWING SECTION EXCEPT THOSE FOR
7474: # PATTERN BLOCKS WHICH ARE IN THE PATTERN MATCHING SEGMENT
7475: # LATER ON (LABELS OF THE FORM P$XXX), AND DOPE VECTORS
7476: # (D$XXX) WHICH ARE IN THE DOPE VECTOR SECTION FOLLOWING
7477: # THE PATTERN ROUTINES (DOPE VECTORS ARE USED FOR CMBLKS).
7478: #
7479: # THE ENTRY POINTS IN THIS SECTION HAVE LABELS OF THE
7480: # FORM B$XXY WHERE XX IS THE TWO CHARACTER BLOCK TYPE FOR
7481: # THE CORRESPONDING BLOCK AND Y IS ANY LETTER.
7482: #
7483: # IN SOME CASES, THE POINTERS SERVE NO OTHER PURPOSE THAN
7484: # TO IDENTIFY THE BLOCK TYPE. IN THIS CASE THE ROUTINE
7485: # IS NEVER EXECUTED AND THUS NO CODE IS ASSEMBLED.
7486: #
7487: # FOR EACH OF THESE ENTRY POINTS CORRESPONDING TO A BLOCK
7488: # AN ENTRY POINT IDENTIFICATION IS ASSEMBLED (BL$XX).
7489: #
7490: # THE EXACT ENTRY CONDITIONS DEPEND ON THE MANNER IN
7491: # WHICH THE ROUTINE IS ACCESSED AND ARE DOCUMENTED WITH
7492: # THE INDIVIDUAL ROUTINES AS REQUIRED.
7493: #
7494: # THE ORDER OF THESE ROUTINES IS ALPHABETICAL WITH THE
7495: # FOLLOWING EXCEPTIONS.
7496: #
7497: # THE ROUTINES FOR SEBLK AND EXBLK ENTRIES OCCUR FIRST SO
7498: # THAT EXPRESSIONS CAN BE QUICKLY IDENTIFIED FROM THE FACT
7499: # THAT THEIR ROUTINES LIE BEFORE THE SYMBOL B$E$$.
7500: #
7501: # THESE ARE IMMEDIATELY FOLLOWED BY THE ROUTINE FOR A TRBLK
7502: # SO THAT THE TEST AGAINST THE SYMBOL B$T$$ CHECKS FOR
7503: # TRAPPED VALUES OR EXPRESSION VALUES (SEE PROCEDURE EVALP)
7504: #
7505: # THE PATTERN ROUTINES LIE AFTER THIS SECTION SO THAT
7506: # PATTERNS ARE IDENTIFIED WITH ROUTINES STARTING AT OR
7507: # AFTER THE INITIAL INSTRUCTION IN THESE ROUTINES (P$AAA).
7508: #
7509: # THE SYMBOL B$AAA DEFINES THE FIRST LOCATION FOR BLOCK
7510: # ROUTINES AND THE SYMBOL P$YYY (AT THE END OF THE PATTERN
7511: # MATCH ROUTINES SECTION) DEFINES THE LAST SUCH ENTRY POINT
7512: #
7513: .align 2
7514: .word bl$$i
7515: b$aaa: # entry point of first block routine
7516: #page
7517: #
7518: # EXBLK
7519: #
7520: # THE ROUTINE FOR AN EXBLK LOADS THE EXPRESSION ONTO
7521: # THE STACK AS A VALUE.
7522: #
7523: # (XR) POINTER TO EXBLK
7524: #
7525: .align 2
7526: .word bl$ex
7527: b$exl: # entry point (exblk)
7528: jmp exixr # stack xr and obey next code word
7529: #page
7530: #
7531: # SEBLK
7532: #
7533: # THE ROUTINE FOR SEBLK IS ACCESSED FROM THE GENERATED
7534: # CODE TO LOAD THE EXPRESSION VALUE ONTO THE STACK.
7535: #
7536: .align 2
7537: .word bl$se
7538: b$sel: # entry point (seblk)
7539: jmp exixr # stack xr and obey next code word
7540: #
7541: # DEFINE SYMBOL WHICH MARKS END OF ENTRIES FOR EXPRESSIONS
7542: #
7543: .align 2
7544: .word bl$$i
7545: b$e$$: # entry point
7546: #page
7547: #
7548: # TRBLK
7549: #
7550: # THE ROUTINE FOR A TRBLK IS NEVER EXECUTED
7551: #
7552: .align 2
7553: .word bl$tr
7554: b$trt: # entry point (trblk)
7555: #
7556: # DEFINE SYMBOL MARKING END OF TRAP AND EXPRESSION BLOCKS
7557: #
7558: .align 2
7559: .word bl$$i
7560: b$t$$: # end of trblk,seblk,exblk entries
7561: #page
7562: #
7563: # ARBLK
7564: #
7565: # THE ROUTINE FOR ARBLK IS NEVER EXECUTED
7566: #
7567: .align 2
7568: .word bl$ar
7569: b$art: # entry point (arblk)
7570: #page
7571: #
7572: # BCBLK
7573: #
7574: # THE ROUTINE FOR A BCBLK IS NEVER EXECUTED
7575: #
7576: # (XR) POINTER TO BCBLK
7577: #
7578: .align 2
7579: .word bl$bc
7580: b$bct: # entry point (bcblk)
7581: #page
7582: #
7583: # BFBLK
7584: #
7585: # THE ROUTINE FOR A BFBLK IS NEVER EXECUTED
7586: #
7587: # (XR) POINTER TO BFBLK
7588: #
7589: .align 2
7590: .word bl$bf
7591: b$bft: # entry point (bfblk)
7592: #page
7593: #
7594: # CCBLK
7595: #
7596: # THE ROUTINE FOR CCBLK IS NEVER ENTERED
7597: #
7598: .align 2
7599: .word bl$cc
7600: b$cct: # entry point (ccblk)
7601: #page
7602: #
7603: # CDBLK
7604: #
7605: # THE CDBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
7606: # THERE ARE TWO CASES DEPENDING ON THE FORM OF CDFAL.
7607: #
7608: # ENTRY FOR COMPLEX FAILURE CODE AT CDFAL
7609: #
7610: # (XR) POINTER TO CDBLK
7611: #
7612: .align 2
7613: .word bl$cd
7614: b$cdc: # entry point (cdblk)
7615: bcdc0: movl flptr,sp # pop garbage off stack
7616: movl 4*cdfal(r9),(sp)# set failure offset
7617: jmp stmgo # enter stmt
7618: #page
7619: #
7620: # CDBLK (CONTINUED)
7621: #
7622: # ENTRY FOR SIMPLE FAILURE CODE AT CDFAL
7623: #
7624: # (XR) POINTER TO CDBLK
7625: #
7626: .align 2
7627: .word bl$cd
7628: b$cds: # entry point (cdblk)
7629: bcds0: movl flptr,sp # pop garbage off stack
7630: movl $4*cdfal,(sp) # set failure offset
7631: jmp stmgo # enter stmt
7632: #page
7633: #
7634: # CMBLK
7635: #
7636: # THE ROUTINE FOR A CMBLK IS NEVER EXECUTED
7637: #
7638: .align 2
7639: .word bl$cm
7640: b$cmt: # entry point (cmblk)
7641: #page
7642: #
7643: # CTBLK
7644: #
7645: # THE ROUTINE FOR A CTBLK IS NEVER EXECUTED
7646: #
7647: .align 2
7648: .word bl$ct
7649: b$ctt: # entry point (ctblk)
7650: #page
7651: #
7652: # DFBLK
7653: #
7654: # THE ROUTINE FOR A DFBLK IS ACCESSED FROM THE O$FNC ENTRY
7655: # TO CALL A DATATYPE FUNCTION AND BUILD A PDBLK.
7656: #
7657: # (XL) POINTER TO DFBLK
7658: #
7659: .align 2
7660: .word bl$df
7661: b$dfc: # entry point
7662: movl 4*dfpdl(r10),r6 # load length of pdblk
7663: jsb alloc # allocate pdblk
7664: movl $b$pdt,(r9) # store type word
7665: movl r10,4*pddfp(r9) # store dfblk pointer
7666: movl r9,r8 # save pointer to pdblk
7667: addl2 r6,r9 # point past pdblk
7668: movl 4*fargs(r10),r6 # set to count fields
7669: #
7670: # LOOP TO ACQUIRE FIELD VALUES FROM STACK
7671: #
7672: bdfc1: movl (sp)+,-(r9) # move a field value
7673: sobgtr r6,bdfc1 # loop till all moved
7674: movl r8,r9 # recall pointer to pdblk
7675: jmp exsid # exit setting id field
7676: #page
7677: #
7678: # EFBLK
7679: #
7680: # THE ROUTINE FOR AN EFBLK IS PASSED CONTROL FORM THE O$FNC
7681: # ENTRY TO CALL AN EXTERNAL FUNCTION.
7682: #
7683: # (XL) POINTER TO EFBLK
7684: #
7685: .align 2
7686: .word bl$ef
7687: b$efc: # entry point (efblk)
7688: movl 4*fargs(r10),r8 # load number of arguments
7689: moval 0[r8],r8 # convert to offset
7690: movl r10,-(sp) # save pointer to efblk
7691: movl sp,r10 # copy pointer to arguments
7692: #
7693: # LOOP TO CONVERT ARGUMENTS
7694: #
7695: befc1: addl2 $4,r10 # point to next entry
7696: movl (sp),r9 # load pointer to efblk
7697: subl2 $4,r8 # decrement eftar offset
7698: addl2 r8,r9 # point to next eftar entry
7699: movl 4*eftar(r9),r9 # load eftar entry
7700: casel r9,$0,$4 # switch on type
7701: 5:
7702: .word befc7-5b # no conversion needed
7703: .word befc2-5b # string
7704: .word befc3-5b # integer
7705: .word befc4-5b # real
7706: #esw # end of switch on type
7707: #
7708: # HERE TO CONVERT TO STRING
7709: #
7710: befc2: movl (r10),-(sp) # stack arg ptr
7711: jsb gtstg # convert argument to string
7712: .long er_039 # external function argument is not string
7713: jmp befc6 # jump to merge
7714: #page
7715: #
7716: # EFBLK (CONTINUED)
7717: #
7718: # HERE TO CONVERT AN INTEGER
7719: #
7720: befc3: movl (r10),r9 # load next argument
7721: movl r8,befof # save offset
7722: jsb gtint # convert to integer
7723: .long er_040 # external function argument is not integer
7724: jmp befc5 # merge with real case
7725: #
7726: # HERE TO CONVERT A REAL
7727: #
7728: befc4: movl (r10),r9 # load next argument
7729: movl r8,befof # save offset
7730: jsb gtrea # convert to real
7731: .long er_265 # external function argument is not real
7732: #
7733: # INTEGER CASE MERGES HERE
7734: #
7735: befc5: movl befof,r8 # restore offset
7736: #
7737: # STRING MERGES HERE
7738: #
7739: befc6: movl r9,(r10) # store converted result
7740: #
7741: # NO CONVERSION MERGES HERE
7742: #
7743: befc7: tstl r8 # loop back if more to go
7744: bnequ befc1
7745: #
7746: # HERE AFTER CONVERTING ALL THE ARGUMENTS
7747: #
7748: movl (sp)+,r10 # restore efblk pointer
7749: movl 4*fargs(r10),r6 # get number of args
7750: jsb sysex # call routine to call external fnc
7751: .long exfal # fail if failure
7752: #page
7753: #
7754: # EFBLK (CONTINUED)
7755: #
7756: # RETURN HERE WITH RESULT IN XR
7757: #
7758: # FIRST DEFEND AGAINST NON-STANDARD NULL STRING RETURNED
7759: #
7760: movl 4*efrsl(r10),r7 # get result type id
7761: tstl r7 # branch if not unconverted
7762: bnequ befa8
7763: cmpl (r9),$b$scl # jump if not a string
7764: bnequ befc8
7765: tstl 4*sclen(r9) # return null if null
7766: bnequ 0f
7767: jmp exnul
7768: 0:
7769: #
7770: # HERE IF CONVERTED RESULT TO CHECK FOR NULL STRING
7771: #
7772: befa8: cmpl r7,$num01 # jump if not a string
7773: bnequ befc8
7774: tstl 4*sclen(r9) # return null if null
7775: bnequ 0f
7776: jmp exnul
7777: 0:
7778: #
7779: # RETURN IF RESULT IS IN DYNAMIC STORAGE
7780: #
7781: befc8: cmpl r9,dnamb # jump if not in dynamic storage
7782: blssu befc9
7783: cmpl r9,dnamp # return result if already dynamic
7784: bgtru 0f
7785: jmp exixr
7786: 0:
7787: #
7788: # HERE WE COPY A RESULT INTO THE DYNAMIC REGION
7789: #
7790: befc9: movl (r9),r6 # get possible type word
7791: tstl r7 # jump if unconverted result
7792: beqlu bef11
7793: movl $b$scl,r6 # string
7794: cmpl r7,$num01 # yes jump
7795: beqlu bef10
7796: movl $b$icl,r6 # integer
7797: cmpl r7,$num02 # yes jump
7798: beqlu bef10
7799: movl $b$rcl,r6 # real
7800: #
7801: # STORE TYPE WORD IN RESULT
7802: #
7803: bef10: movl r6,(r9) # stored before copying to dynamic
7804: #
7805: # MERGE FOR UNCONVERTED RESULT
7806: #
7807: bef11: jsb blkln # get length of block
7808: movl r9,r10 # copy address of old block
7809: jsb alloc # allocate dynamic block same size
7810: movl r9,-(sp) # set pointer to new block as result
7811: jsb sbmvw # copy old block to dynamic block
7812: jmp exits # exit with result on stack
7813: #page
7814: #
7815: # EVBLK
7816: #
7817: # THE ROUTINE FOR AN EVBLK IS NEVER EXECUTED
7818: #
7819: .align 2
7820: .word bl$ev
7821: b$evt: # entry point (evblk)
7822: #page
7823: #
7824: # FFBLK
7825: #
7826: # THE ROUTINE FOR AN FFBLK IS EXECUTED FROM THE O$FNC ENTRY
7827: # TO CALL A FIELD FUNCTION AND EXTRACT A FIELD VALUE/NAME.
7828: #
7829: # (XL) POINTER TO FFBLK
7830: #
7831: .align 2
7832: .word bl$ff
7833: b$ffc: # entry point (ffblk)
7834: movl r10,r9 # copy ffblk pointer
7835: movl (r3)+,r8 # load next code word
7836: movl (sp),r10 # load pdblk pointer
7837: cmpl (r10),$b$pdt # jump if not pdblk at all
7838: bnequ bffc2
7839: movl 4*pddfp(r10),r6 # load dfblk pointer from pdblk
7840: #
7841: # LOOP TO FIND CORRECT FFBLK FOR THIS PDBLK
7842: #
7843: bffc1: cmpl r6,4*ffdfp(r9) # jump if this is the correct ffblk
7844: beqlu bffc3
7845: movl 4*ffnxt(r9),r9 # else link to next ffblk on chain
7846: tstl r9 # loop back if another entry to check
7847: bnequ bffc1
7848: #
7849: # HERE FOR BAD ARGUMENT
7850: #
7851: bffc2: jmp er_041 # field function argument is wrong datatype
7852: #page
7853: #
7854: # FFBLK (CONTINUED)
7855: #
7856: # HERE AFTER LOCATING CORRECT FFBLK
7857: #
7858: bffc3: movl 4*ffofs(r9),r6 # load field offset
7859: cmpl r8,$ofne$ # jump if called by name
7860: beqlu bffc5
7861: addl2 r6,r10 # else point to value field
7862: movl (r10),r9 # load value
7863: cmpl (r9),$b$trt # jump if not trapped
7864: bnequ bffc4
7865: subl2 r6,r10 # else restore name base,offset
7866: movl r8,(sp) # save next code word over pdblk ptr
7867: jsb acess # access value
7868: .long exfal # fail if access fails
7869: movl (sp),r8 # restore next code word
7870: #
7871: # HERE AFTER GETTING VALUE IN (XR)
7872: #
7873: bffc4: movl r9,(sp) # store value on stack (over pdblk)
7874: movl r8,r9 # copy next code word
7875: movl (r9),r10 # load entry address
7876: movl r10,r11 # jump to routine for next code word
7877: jmp (r11)
7878: #
7879: # HERE IF CALLED BY NAME
7880: #
7881: bffc5: movl r6,-(sp) # store name offset (base is set)
7882: jmp exits # exit with name on stack
7883: #page
7884: #
7885: # ICBLK
7886: #
7887: # THE ROUTINE FOR ICBLK IS EXECUTED FROM THE GENERATED
7888: # CODE TO LOAD AN INTEGER VALUE ONTO THE STACK.
7889: #
7890: # (XR) POINTER TO ICBLK
7891: #
7892: .align 2
7893: .word bl$ic
7894: b$icl: # entry point (icblk)
7895: jmp exixr # stack xr and obey next code word
7896: #page
7897: #
7898: # KVBLK
7899: #
7900: # THE ROUTINE FOR A KVBLK IS NEVER EXECUTED.
7901: #
7902: .align 2
7903: .word bl$kv
7904: b$kvt: # entry point (kvblk)
7905: #page
7906: #
7907: # NMBLK
7908: #
7909: # THE ROUTINE FOR A NMBLK IS EXECUTED FROM THE GENERATED
7910: # CODE FOR THE CASE OF LOADING A NAME ONTO THE STACK
7911: # WHERE THE NAME IS THAT OF A NATURAL VARIABLE WHICH CAN
7912: # BE PREEVALUATED AT COMPILE TIME.
7913: #
7914: # (XR) POINTER TO NMBLK
7915: #
7916: .align 2
7917: .word bl$nm
7918: b$nml: # entry point (nmblk)
7919: jmp exixr # stack xr and obey next code word
7920: #page
7921: #
7922: # PDBLK
7923: #
7924: # THE ROUTINE FOR A PDBLK IS NEVER EXECUTED
7925: #
7926: .align 2
7927: .word bl$pd
7928: b$pdt: # entry point (pdblk)
7929: #page
7930: #
7931: # PFBLK
7932: #
7933: # THE ROUTINE FOR A PFBLK IS EXECUTED FROM THE ENTRY O$FNC
7934: # TO CALL A PROGRAM DEFINED FUNCTION.
7935: #
7936: # (XL) POINTER TO PFBLK
7937: #
7938: # THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING
7939: # CONTROL TO THE PROGRAM DEFINED FUNCTION.
7940: #
7941: # SAVED VALUE OF FIRST ARGUMENT
7942: # .
7943: # SAVED VALUE OF LAST ARGUMENT
7944: # SAVED VALUE OF FIRST LOCAL
7945: # .
7946: # SAVED VALUE OF LAST LOCAL
7947: # SAVED VALUE OF FUNCTION NAME
7948: # SAVED CODE BLOCK PTR (R$COD)
7949: # SAVED CODE POINTER (-R$COD)
7950: # SAVED VALUE OF FLPRT
7951: # SAVED VALUE OF FLPTR
7952: # POINTER TO PFBLK
7953: # FLPTR --------------- ZERO (TO BE OVERWRITTEN WITH OFFS)
7954: #
7955: .align 2
7956: .word bl$pf
7957: b$pfc: # entry point (pfblk)
7958: movl r10,bpfpf # save pfblk ptr (need not be reloc)
7959: movl r10,r9 # copy for the moment
7960: movl 4*pfvbl(r9),r10 # point to vrblk for function
7961: #
7962: # LOOP TO FIND OLD VALUE OF FUNCTION
7963: #
7964: bpf01: movl r10,r7 # save pointer
7965: movl 4*vrval(r10),r10# load value
7966: cmpl (r10),$b$trt # loop if trblk
7967: beqlu bpf01
7968: #
7969: # SET VALUE TO NULL AND SAVE OLD FUNCTION VALUE
7970: #
7971: movl r10,bpfsv # save old value
7972: movl r7,r10 # point back to block with value
7973: movl $nulls,4*vrval(r10) # set value to null
7974: movl 4*fargs(r9),r6 # load number of arguments
7975: addl2 $4*pfarg,r9 # point to pfarg entries
7976: tstl r6 # jump if no arguments
7977: beqlu bpf04
7978: movl sp,r10 # ptr to last arg
7979: moval 0[r6],r6 # convert no. of args to bytes offset
7980: addl2 r6,r10 # point before first arg
7981: movl r10,bpfxt # remember arg pointer
7982: #page
7983: #
7984: # PFBLK (CONTINUED)
7985: #
7986: # LOOP TO SAVE OLD ARGUMENT VALUES AND SET NEW ONES
7987: #
7988: bpf02: movl (r9)+,r10 # load vrblk ptr for next argument
7989: #
7990: # LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
7991: #
7992: bpf03: movl r10,r8 # save pointer
7993: movl 4*vrval(r10),r10# load next value
7994: cmpl (r10),$b$trt # loop back if trblk
7995: beqlu bpf03
7996: #
7997: # SAVE OLD VALUE AND GET NEW VALUE
7998: #
7999: movl r10,r6 # keep old value
8000: movl bpfxt,r10 # point before next stacked arg
8001: movl -(r10),r7 # load argument (new value)
8002: movl r6,(r10) # save old value
8003: movl r10,bpfxt # keep arg ptr for next time
8004: movl r8,r10 # point back to block with value
8005: movl r7,4*vrval(r10) # set new value
8006: cmpl sp,bpfxt # loop if not all done
8007: bnequ bpf02
8008: #
8009: # NOW PROCESS LOCALS
8010: #
8011: bpf04: movl bpfpf,r10 # restore pfblk pointer
8012: movl 4*pfnlo(r10),r6 # load number of locals
8013: tstl r6 # jump if no locals
8014: beqlu bpf07
8015: movl $nulls,r7 # get null constant
8016: # set local counter
8017: #
8018: # LOOP TO PROCESS LOCALS
8019: #
8020: bpf05: movl (r9)+,r10 # load vrblk ptr for next local
8021: #
8022: # LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
8023: #
8024: bpf06: movl r10,r8 # save pointer
8025: movl 4*vrval(r10),r10# load next value
8026: cmpl (r10),$b$trt # loop back if trblk
8027: beqlu bpf06
8028: #
8029: # SAVE OLD VALUE AND SET NULL AS NEW VALUE
8030: #
8031: movl r10,-(sp) # stack old value
8032: movl r8,r10 # point back to block with value
8033: movl r7,4*vrval(r10) # set null as new value
8034: sobgtr r6,bpf05 # loop till all locals processed
8035: #page
8036: #
8037: # PFBLK (CONTINUED)
8038: #
8039: # HERE AFTER PROCESSING ARGUMENTS AND LOCALS
8040: #
8041: bpf07: clrl r9 # zero reg xr in case
8042: tstl kvpfl # skip if profiling is off
8043: beqlu bpf7c
8044: cmpl kvpfl,$num02 # branch on type of profile
8045: beqlu bpf7a
8046: #
8047: # HERE IF &PROFILE = 1
8048: #
8049: jsb systm # get current time
8050: movl r5,pfetm # save for a sec
8051: subl2 pfstm,r5 # find time used by caller
8052: jsb icbld # build into an icblk
8053: movl pfetm,r5 # reload current time
8054: jmp bpf7b # merge
8055: #
8056: # HERE IF &PROFILE = 2
8057: #
8058: bpf7a: movl pfstm,r5 # get start time of calling stmt
8059: jsb icbld # assemble an icblk round it
8060: jsb systm # get now time
8061: #
8062: # BOTH TYPES OF PROFILE MERGE HERE
8063: #
8064: bpf7b: movl r5,pfstm # set start time of 1st func stmt
8065: movl sp,pffnc # flag function entry
8066: #
8067: # NO PROFILING MERGES HERE
8068: #
8069: bpf7c: movl r9,-(sp) # stack icblk ptr (or zero)
8070: movl r$cod,r6 # load old code block pointer
8071: movl r3,r7 # get code pointer
8072: subl2 r6,r7 # make code pointer into offset
8073: movl bpfpf,r10 # recall pfblk pointer
8074: movl bpfsv,-(sp) # stack old value of function name
8075: movl r6,-(sp) # stack code block pointer
8076: movl r7,-(sp) # stack code offset
8077: movl flprt,-(sp) # stack old flprt
8078: movl flptr,-(sp) # stack old failure pointer
8079: movl r10,-(sp) # stack pointer to pfblk
8080: clrl -(sp) # dummy zero entry for fail return
8081: jsb sbchk # check for stack overflow
8082: movl sp,flptr # set new fail return value
8083: movl sp,flprt # set new flprt
8084: movl kvtra,r6 # load trace value
8085: addl2 kvftr,r6 # add ftrace value
8086: tstl r6 # jump if tracing possible
8087: bnequ bpf09
8088: incl kvfnc # else bump fnclevel
8089: #
8090: # HERE TO ACTUALLY JUMP TO FUNCTION
8091: #
8092: bpf08: movl 4*pfcod(r10),r9 # point to code
8093: movl (r9),r11 # off to execute function
8094: jmp (r11)
8095: #
8096: # HERE IF TRACING IS POSSIBLE
8097: #
8098: bpf09: movl 4*pfctr(r10),r9 # load possible call trace trblk
8099: movl 4*pfvbl(r10),r10# load vrblk pointer for function
8100: movl $4*vrval,r6 # set name offset for variable
8101: tstl kvtra # jump if trace mode is off
8102: beqlu bpf10
8103: tstl r9 # or if there is no call trace
8104: beqlu bpf10
8105: #
8106: # HERE IF CALL TRACED
8107: #
8108: decl kvtra # decrement trace count
8109: tstl 4*trfnc(r9) # jump if print trace
8110: beqlu bpf11
8111: jsb trxeq # execute function type trace
8112: #page
8113: #
8114: # PFBLK (CONTINUED)
8115: #
8116: # HERE TO TEST FOR FTRACE TRACE
8117: #
8118: bpf10: tstl kvftr # jump if ftrace is off
8119: beqlu bpf16
8120: decl kvftr # else decrement ftrace
8121: #
8122: # HERE FOR PRINT TRACE
8123: #
8124: bpf11: jsb prtsn # print statement number
8125: jsb prtnm # print function name
8126: movl $ch$pp,r6 # load left paren
8127: jsb prtch # print left paren
8128: movl 4*1(sp),r10 # recover pfblk pointer
8129: tstl 4*fargs(r10) # skip if no arguments
8130: beqlu bpf15
8131: clrl r7 # else set argument counter
8132: jmp bpf13 # jump into loop
8133: #
8134: # LOOP TO PRINT ARGUMENT VALUES
8135: #
8136: bpf12: movl $ch$cm,r6 # load comma
8137: jsb prtch # print to separate from last arg
8138: #
8139: # MERGE HERE FIRST TIME (NO COMMA REQUIRED)
8140: #
8141: bpf13: movl r7,(sp) # save arg ctr (over failoffs is ok)
8142: moval 0[r7],r7 # convert to byte offset
8143: addl2 r7,r10 # point to next argument pointer
8144: movl 4*pfarg(r10),r9 # load next argument vrblk ptr
8145: subl2 r7,r10 # restore pfblk pointer
8146: movl 4*vrval(r9),r9 # load next value
8147: jsb prtvl # print argument value
8148: #page
8149: #
8150: # HERE AFTER DEALING WITH ONE ARGUMENT
8151: #
8152: movl (sp),r7 # restore argument counter
8153: incl r7 # increment argument counter
8154: cmpl r7,4*fargs(r10) # loop if more to print
8155: blssu bpf12
8156: #
8157: # MERGE HERE IN NO ARGS CASE TO PRINT PAREN
8158: #
8159: bpf15: movl $ch$rp,r6 # load right paren
8160: jsb prtch # print to terminate output
8161: jsb prtnl # terminate print line
8162: #
8163: # MERGE HERE TO EXIT WITH TEST FOR FNCLEVEL TRACE
8164: #
8165: bpf16: incl kvfnc # increment fnclevel
8166: movl r$fnc,r10 # load ptr to possible trblk
8167: jsb ktrex # call keyword trace routine
8168: #
8169: # CALL FUNCTION AFTER TRACE TESTS COMPLETE
8170: #
8171: movl 4*1(sp),r10 # restore pfblk pointer
8172: jmp bpf08 # jump back to execute function
8173: #page
8174: #
8175: # RCBLK
8176: #
8177: # THE ROUTINE FOR AN RCBLK IS EXECUTED FROM THE GENERATED
8178: # CODE TO LOAD A REAL VALUE ONTO THE STACK.
8179: #
8180: # (XR) POINTER TO RCBLK
8181: #
8182: .align 2
8183: .word bl$rc
8184: b$rcl: # entry point (rcblk)
8185: jmp exixr # stack xr and obey next code word
8186: #page
8187: #
8188: # SCBLK
8189: #
8190: # THE ROUTINE FOR AN SCBLK IS EXECUTED FROM THE GENERATED
8191: # CODE TO LOAD A STRING VALUE ONTO THE STACK.
8192: #
8193: # (XR) POINTER TO SCBLK
8194: #
8195: .align 2
8196: .word bl$sc
8197: b$scl: # entry point (scblk)
8198: jmp exixr # stack xr and obey next code word
8199: #page
8200: #
8201: # TBBLK
8202: #
8203: # THE ROUTINE FOR A TBBLK IS NEVER EXECUTED
8204: #
8205: .align 2
8206: .word bl$tb
8207: b$tbt: # entry point (tbblk)
8208: #page
8209: #
8210: # TEBLK
8211: #
8212: # THE ROUTINE FOR A TEBLK IS NEVER EXECUTED
8213: #
8214: .align 2
8215: .word bl$te
8216: b$tet: # entry point (teblk)
8217: #page
8218: #
8219: # VCBLK
8220: #
8221: # THE ROUTINE FOR A VCBLK IS NEVER EXECUTED
8222: #
8223: .align 2
8224: .word bl$vc
8225: b$vct: # entry point (vcblk)
8226: #page
8227: #
8228: # VRBLK
8229: #
8230: # THE VRBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
8231: # THERE ARE SIX ENTRIES FOR VRBLK COVERING VARIOUS CASES
8232: #
8233: .align 2
8234: .word bl$$i
8235: b$vr$: # mark start of vrblk entry points
8236: #
8237: # ENTRY FOR VRGET (TRAPPED CASE). THIS ROUTINE IS CALLED
8238: # FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE.
8239: # THIS ENTRY POINT IS USED IF AN ACCESS TRACE OR INPUT
8240: # ASSOCIATION IS CURRENTLY ACTIVE.
8241: #
8242: # (XR) POINTER TO VRGET FIELD OF VRBLK
8243: #
8244: .align 2
8245: .word bl$$i
8246: b$vra: # entry point
8247: movl r9,r10 # copy name base (vrget = 0)
8248: movl $4*vrval,r6 # set name offset
8249: jsb acess # access value
8250: .long exfal # fail if access fails
8251: jmp exixr # else exit with result in xr
8252: #page
8253: #
8254: # VRBLK (CONTINUED)
8255: #
8256: # ENTRY FOR VRSTO (ERROR CASE. THIS ROUTINE IS CALLED FROM
8257: # THE EXECUTED CODE FOR AN ATTEMPT TO MODIFY THE VALUE
8258: # OF A PROTECTED (PATTERN VALUED) NATURAL VARIABLE.
8259: #
8260: b$vre: # entry point
8261: jmp er_042 # attempt to change value of protected variable
8262: #page
8263: #
8264: # VRBLK (CONTINUED)
8265: #
8266: # ENTRY FOR VRTRA (UNTRAPPED CASE). THIS ROUTINE IS CALLED
8267: # FROM THE EXECUTED CODE TO TRANSFER TO A LABEL.
8268: #
8269: # (XR) POINTER TO VRTRA FIELD OF VRBLK
8270: #
8271: b$vrg: # entry point
8272: movl 4*vrlbo(r9),r9 # load code pointer
8273: movl (r9),r10 # load entry address
8274: movl r10,r11 # jump to routine for next code word
8275: jmp (r11)
8276: #page
8277: #
8278: # VRBLK (CONTINUED)
8279: #
8280: # ENTRY FOR VRGET (UNTRAPPED CASE). THIS ROUTINE IS CALLED
8281: # FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE.
8282: #
8283: # (XR) POINTS TO VRGET FIELD OF VRBLK
8284: #
8285: b$vrl: # entry point
8286: movl 4*vrval(r9),-(sp)# load value onto stack (vrget = 0)
8287: jmp exits # obey next code word
8288: #page
8289: #
8290: # VRBLK (CONTINUED)
8291: #
8292: # ENTRY FOR VRSTO (UNTRAPPED CASE). THIS ROUTINE IS CALLED
8293: # FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE.
8294: #
8295: # (XR) POINTER TO VRSTO FIELD OF VRBLK
8296: #
8297: b$vrs: # entry point
8298: movl (sp),4*vrvlo(r9)# store value, leave on stack
8299: jmp exits # obey next code word
8300: #page
8301: #
8302: # VRBLK (CONTINUED)
8303: #
8304: # VRTRA (TRAPPED CASE). THIS ROUTINE IS CALLED FROM THE
8305: # GENERATED CODE TO TRANSFER TO A LABEL WHEN A LABEL
8306: # TRACE IS CURRENTLY ACTIVE.
8307: #
8308: b$vrt: # entry point
8309: subl2 $4*vrtra,r9 # point back to start of vrblk
8310: movl r9,r10 # copy vrblk pointer
8311: movl $4*vrval,r6 # set name offset
8312: movl 4*vrlbl(r10),r9 # load pointer to trblk
8313: tstl kvtra # jump if trace is off
8314: beqlu bvrt2
8315: decl kvtra # else decrement trace count
8316: tstl 4*trfnc(r9) # jump if print trace case
8317: beqlu bvrt1
8318: jsb trxeq # else execute full trace
8319: jmp bvrt2 # merge to jump to label
8320: #
8321: # HERE FOR PRINT TRACE -- PRINT COLON ( LABEL NAME )
8322: #
8323: bvrt1: jsb prtsn # print statement number
8324: movl r10,r9 # copy vrblk pointer
8325: movl $ch$cl,r6 # colon
8326: jsb prtch # print it
8327: movl $ch$pp,r6 # left paren
8328: jsb prtch # print it
8329: jsb prtvn # print label name
8330: movl $ch$rp,r6 # right paren
8331: jsb prtch # print it
8332: jsb prtnl # terminate line
8333: movl 4*vrlbl(r10),r9 # point back to trblk
8334: #
8335: # MERGE HERE TO JUMP TO LABEL
8336: #
8337: bvrt2: movl 4*trlbl(r9),r9 # load pointer to actual code
8338: movl (r9),r11 # execute statement at label
8339: jmp (r11)
8340: #page
8341: #
8342: # VRBLK (CONTINUED)
8343: #
8344: # ENTRY FOR VRSTO (TRAPPED CASE). THIS ROUTINE IS CALLED
8345: # FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE.
8346: # THIS ENTRY IS USED WHEN A VALUE TRACE OR OUTPUT
8347: # ASSOCIATION IS CURRENTLY ACTIVE.
8348: #
8349: # (XR) POINTER TO VRSTO FIELD OF VRBLK
8350: #
8351: b$vrv: # entry point
8352: movl (sp),r7 # load value (leave copy on stack)
8353: subl2 $4*vrsto,r9 # point to vrblk
8354: movl r9,r10 # copy vrblk pointer
8355: movl $4*vrval,r6 # set offset
8356: jsb asign # call assignment routine
8357: .long exfal # fail if assignment fails
8358: jmp exits # else return with result on stack
8359: #page
8360: #
8361: # XNBLK
8362: #
8363: # THE ROUTINE FOR AN XNBLK IS NEVER EXECUTED
8364: #
8365: .align 2
8366: .word bl$xn
8367: b$xnt: # entry point (xnblk)
8368: #page
8369: #
8370: # XRBLK
8371: #
8372: # THE ROUTINE FOR AN XRBLK IS NEVER EXECUTED
8373: #
8374: .align 2
8375: .word bl$xr
8376: b$xrt: # entry point (xrblk)
8377: #
8378: # MARK ENTRY ADDRESS PAST LAST BLOCK ACTION ROUTINE
8379: #
8380: .align 2
8381: .word bl$$i
8382: b$yyy: # last block routine entry point
8383: #title s p i t b o l -- pattern matching routines
8384: #
8385: # THE FOLLOWING SECTION CONSISTS OF THE PATTERN MATCHING
8386: # ROUTINES. ALL PATTERN NODES CONTAIN A POINTER (PCODE)
8387: # TO ONE OF THE ROUTINES IN THIS SECTION (P$XXX).
8388: #
8389: # NOTE THAT THIS SECTION FOLLOWS THE B$XXX ROUTINES TO
8390: # ENABLE A FAST TEST FOR THE PATTERN DATATYPE.
8391: #
8392: .align 2
8393: .word bl$$i
8394: p$aaa: # entry to mark first pattern
8395: #
8396: #
8397: # THE ENTRY CONDITIONS TO THE MATCH ROUTINE ARE AS FOLLOWS
8398: # (SEE O$PMN, O$PMV, O$PMS AND PROCEDURE MATCH).
8399: #
8400: # STACK CONTENTS.
8401: #
8402: # NAME BASE (O$PMN ONLY)
8403: # NAME OFFSET (O$PMN ONLY)
8404: # TYPE (0-O$PMN, 1-O$PMV, 2-O$PMS)
8405: # PMHBS --------------- INITIAL CURSOR (ZERO)
8406: # INITIAL NODE POINTER
8407: # XS ------------------ =NDABO (ANCHORED), =NDUNA (UNANCH)
8408: #
8409: # REGISTER VALUES.
8410: #
8411: # (XS) SET AS SHOWN IN STACK DIAGRAM
8412: # (XR) POINTER TO INITIAL PATTERN NODE
8413: # (WB) INITIAL CURSOR (ZERO)
8414: #
8415: # GLOBAL PATTERN VALUES
8416: #
8417: # R$PMS POINTER TO SUBJECT STRING SCBLK
8418: # PMSSL LENGTH OF SUBJECT STRING IN CHARS
8419: # PMDFL DOT FLAG, INITIALLY ZERO
8420: # PMHBS SET AS SHOWN IN STACK DIAGRAM
8421: #
8422: # CONTROL IS PASSED BY BRANCHING THROUGH THE PCODE
8423: # FIELD OF THE INITIAL PATTERN NODE (BRI (XR)).
8424: #page
8425: #
8426: # DESCRIPTION OF ALGORITHM
8427: #
8428: # A PATTERN STRUCTURE IS REPRESENTED AS A LINKED GRAPH
8429: # OF NODES WITH THE FOLLOWING STRUCTURE.
8430: #
8431: # +------------------------------------+
8432: # I PCODE I
8433: # +------------------------------------+
8434: # I PTHEN I
8435: # +------------------------------------+
8436: # I PARM1 I
8437: # +------------------------------------+
8438: # I PARM2 I
8439: # +------------------------------------+
8440: #
8441: # PCODE IS A POINTER TO THE ROUTINE WHICH WILL PERFORM
8442: # THE MATCH OF THIS PARTICULAR NODE TYPE.
8443: #
8444: # PTHEN IS A POINTER TO THE SUCCESSOR NODE. I.E. THE NODE
8445: # TO BE MATCHED IF THE ATTEMPT TO MATCH THIS NODE SUCCEEDS.
8446: # IF THIS IS THE LAST NODE OF THE PATTERN PTHEN POINTS
8447: # TO THE DUMMY NODE NDNTH WHICH INITIATES PATTERN EXIT.
8448: #
8449: # PARM1, PARM2 ARE PARAMETERS WHOSE USE VARIES WITH THE
8450: # PARTICULAR NODE. THEY ARE ONLY PRESENT IF REQUIRED.
8451: #
8452: # ALTERNATIVES ARE HANDLED WITH THE SPECIAL ALTERNATIVE
8453: # NODE WHOSE PARAMETER POINTS TO THE NODE TO BE MATCHED
8454: # IF THERE IS A FAILURE ON THE SUCCESSOR PATH.
8455: #
8456: # THE FOLLOWING EXAMPLE ILLUSTRATES THE MANNER IN WHICH
8457: # THE STRUCTURE IS BUILT UP. THE PATTERN IS
8458: #
8459: # (A / B / C) (D / E) WHERE / IS ALTERNATION
8460: #
8461: # IN THE DIAGRAM, THE NODE MARKED + REPRESENTS AN
8462: # ALTERNATIVE NODE AND THE DOTTED LINE FROM A + NODE
8463: # REPRESENTS THE PARAMETER POINTER TO THE ALTERNATIVE.
8464: #
8465: # +---+ +---+ +---+ +---+
8466: # I + I-----I A I-----I + I-----I D I-----
8467: # +---+ +---+ I +---+ +---+
8468: # . I .
8469: # . I .
8470: # +---+ +---+ I +---+
8471: # I + I-----I B I--I I E I-----
8472: # +---+ +---+ I +---+
8473: # . I
8474: # . I
8475: # +---+ I
8476: # I C I------------I
8477: # +---+
8478: #page
8479: #
8480: # DURING THE MATCH, THE REGISTERS ARE USED AS FOLLOWS.
8481: #
8482: # (XR) POINTS TO THE CURRENT NODE
8483: # (XL) SCRATCH
8484: # (XS) MAIN STACK POINTER
8485: # (WB) CURSOR (NUMBER OF CHARS MATCHED)
8486: # (WA,WC) SCRATCH
8487: #
8488: # TO KEEP TRACK OF ALTERNATIVES, THE MAIN STACK IS USED AS
8489: # A HISTORY STACK AND CONTAINS TWO WORD ENTRIES.
8490: #
8491: # WORD 1 SAVED CURSOR VALUE
8492: # WORD 2 NODE TO MATCH ON FAILURE
8493: #
8494: # WHEN A FAILURE OCCURS, THE MOST RECENT ENTRY ON THIS
8495: # STACK IS POPPED OFF TO RESTORE THE CURSOR AND POINT
8496: # TO THE NODE TO BE MATCHED AS AN ALTERNATIVE. THE ENTRY
8497: # AT THE BOTTOM OF THE STACK POINTS TO THE FOLLOWING
8498: # SPECIAL NODES DEPENDING ON THE SCAN MODE.
8499: #
8500: # ANCHORED MODE THE BOTTOM ENTRY POINTS TO THE
8501: # SPECIAL NODE NDABO WHICH CAUSES AN
8502: # ABORT. THE CURSOR VALUE STORED
8503: # WITH THIS ENTRY IS ALWAYS ZERO.
8504: #
8505: # UNANCHORED MODE THE BOTTOM ENTRY POINTS TO THE
8506: # SPECIAL NODE NDUNA WHICH MOVES THE
8507: # ANCHOR POINT AND RESTARTS THE MATCH
8508: # THE CURSOR SAVED WITH THIS ENTRY
8509: # IS THE NUMBER OF CHARACTERS WHICH
8510: # LIE BEFORE THE INITIAL ANCHOR POINT
8511: # (I.E. THE NUMBER OF ANCHOR MOVES).
8512: # THIS ENTRY IS THREE WORDS LONG AND
8513: # ALSO CONTAINS THE INITIAL PATTERN.
8514: #
8515: # ENTRIES ARE MADE ON THIS HISTORY STACK BY ALTERNATIVE
8516: # NODES AND BY SOME SPECIAL COMPOUD PATTERNS AS DESCRIBED
8517: # LATER ON. THE FOLLOWING GLOBAL LOCATIONS ARE USED DURING
8518: # PATTERN MATCHING.
8519: #
8520: # R$PMS POINTER TO SUBJECT STRING
8521: # PMSSL LENGTH OF SUBJECT STRING
8522: # PMDFL FLAG SET NON-ZERO FOR DOT PATTERNS
8523: # PMHBS BASE PTR FOR CURRENT HISTORY STACK
8524: #
8525: # THE FOLLOWING EXIT POINTS ARE AVAILABLE TO MATCH ROUTINES
8526: #
8527: # SUCCP SUCCESS IN MATCHING CURRENT NODE
8528: # FAILP FAILURE IN MATCHING CURRENT NODE
8529: #page
8530: #
8531: # COMPOUND PATTERNS
8532: #
8533: # SOME PATTERNS HAVE IMPLICIT ALTERNATIVES AND THEIR
8534: # REPRESENTATION IN THE PATTERN STRUCTURE CONSISTS OF A
8535: # LINKED SET OF NODES AS INDICATED BY THESE DIAGRAMS.
8536: #
8537: # AS BEFORE, THE + REPRESENTS AN ALTERNATIVE NODE AND
8538: # THE DOTTED LINE FROM A + NODE IS THE PARAMETER POINTER
8539: # TO THE ALTERNATIVE PATTERN.
8540: #
8541: # ARB
8542: # ---
8543: #
8544: # +---+ THIS NODE (P$ARB) MATCHES NULL
8545: # I B I----- AND STACKS CURSOR, SUCCESSOR PTR,
8546: # +---+ CURSOR (COPY) AND A PTR TO NDARC.
8547: #
8548: #
8549: #
8550: #
8551: # BAL
8552: # ---
8553: #
8554: # +---+ THE P$BAL NODE SCANS A BALANCED
8555: # I B I----- STRING AND THEN STACKS A POINTER
8556: # +---+ TO ITSELF ON THE HISTORY STACK.
8557: #page
8558: #
8559: # COMPOUND PATTERN STRUCTURES (CONTINUED)
8560: #
8561: #
8562: # ARBNO
8563: # -----
8564: #
8565: # +---+ THIS ALTERNATIVE NODE MATCHES NULL
8566: # +----I + I----- THE FIRST TIME AND STACKS A POINTER
8567: # I +---+ TO THE ARGUMENT PATTERN X.
8568: # I .
8569: # I .
8570: # I +---+ NODE (P$ABA) TO STACK CURSOR
8571: # I I A I AND HISTORY STACK BASE PTR.
8572: # I +---+
8573: # I I
8574: # I I
8575: # I +---+ THIS IS THE ARGUMENT PATTERN. AS
8576: # I I X I INDICATED, THE SUCCESSOR OF THE
8577: # I +---+ PATTERN IS THE P$ABC NODE
8578: # I I
8579: # I I
8580: # I +---+ THIS NODE (P$ABC) POPS PMHBS,
8581: # +----I C I STACKS OLD PMHBS AND PTR TO NDABD
8582: # +---+ (UNLESS OPTIMISATION HAS OCCURRED)
8583: #
8584: # STRUCTURE AND EXECUTION OF THIS PATTERN RESEMBLE THOSE OF
8585: # RECURSIVE PATTERN MATCHING AND IMMEDIATE ASSIGNMENT.
8586: # THE ALTERNATIVE NODE AT THE HEAD OF THE STRUCTURE MATCHES
8587: # NULL INITIALLY BUT ON SUBSEQUENT FAILURE ENSURES ATTEMPT
8588: # TO MATCH THE ARGUMENT. BEFORE THE ARGUMENT IS MATCHED
8589: # P$ABA STACKS THE CURSOR,PMHBS AND A PTR TO P$ABB. IF
8590: # THE ARGUMENT CANT BE MATCHED , P$ABB REMOVES THIS SPECIAL
8591: # STACK ENTRY AND FAILS.
8592: # IF ARGUMENT IS MATCHED , P$ABC RESTORES THE OUTER PMHBS
8593: # VALUE (SAVED BY P$ABA) . THEN IF THE ARGUMENT HAS LEFT
8594: # ALTERNATIVES ON STACK IT STACKS THE INNER VALUE OF PMHBS
8595: # AND A PTR TO NDABD. IF ARGUMENT LEFT NOTHING ON THE STACK
8596: # IT OPTIMISES BY REMOVING ITEMS STACKED BY P$ABA. FINALLY
8597: # A CHECK IS MADE THAT ARGUMENT MATCHED MORE THAN THE NULL
8598: # STRING (CHECK IS INTENDED TO PREVENT USELESS LOOPING).
8599: # IF SO THE SUCCESSOR IS AGAIN THE ALTERNATIVE NODE AT THE
8600: # HEAD OF THE STRUCTURE , ENSURING A POSSIBLE EXTRA ATTEMPT
8601: # TO MATCH THE ARG IF NECESSARY. IF NOT , THE SUCCESSOR TO
8602: # ALTERNATIVE IS TAKEN SO AS TO TERMINATE THE LOOP. P$ABD
8603: # RESTORES INNER PMHBS PTR AND FAILS , THUS TRYING TO MATCH
8604: # ALTERNATIVES LEFT BY THE ARBNO ARGUMENT.
8605: #page
8606: #
8607: # COMPOUND PATTERN STRUCTURES (CONTINUED)
8608: #
8609: # BREAKX
8610: # ------
8611: #
8612: # +---+ THIS NODE IS A BREAK NODE FOR
8613: # +----I B I THE ARGUMENT TO BREAKX, IDENTICAL
8614: # I +---+ TO AN ORDINARY BREAK NODE.
8615: # I I
8616: # I I
8617: # I +---+ THIS ALTERNATIVE NODE STACKS A
8618: # I I + I----- POINTER TO THE BREAKX NODE TO
8619: # I +---+ ALLOW FOR SUBSEQUENT FAILURE
8620: # I .
8621: # I .
8622: # I +---+ THIS IS THE BREAKX NODE ITSELF. IT
8623: # +----I X I MATCHES ONE CHARACTER AND THEN
8624: # +---+ PROCEEDS BACK TO THE BREAK NODE.
8625: #
8626: #
8627: #
8628: #
8629: # FENCE
8630: # -----
8631: #
8632: # +---+ THE FENCE NODE MATCHES NULL AND
8633: # I F I----- STACKS A POINTER TO NODE NDABO TO
8634: # +---+ ABORT ON A SUBSEQUENT REMATCH
8635: #
8636: #
8637: #
8638: #
8639: # SUCCEED
8640: # -------
8641: #
8642: # +---+ THE NODE FOR SUCCEED MATCHES NULL
8643: # I S I----- AND STACKS A POINTER TO ITSELF
8644: # +---+ TO REPEAT THE MATCH ON A FAILURE.
8645: #page
8646: #
8647: # COMPOUND PATTERNS (CONTINUED)
8648: #
8649: # BINARY DOT (PATTERN ASSIGNMENT)
8650: # -------------------------------
8651: #
8652: # +---+ THIS NODE (P$PAA) SAVES THE CURRENT
8653: # I A I CURSOR AND A POINTER TO THE
8654: # +---+ SPECIAL NODE NDPAB ON THE STACK.
8655: # I
8656: # I
8657: # +---+ THIS IS THE STRUCTURE FOR THE
8658: # I X I PATTERN LEFT ARGUMENT OF THE
8659: # +---+ PATTERN ASSIGNMENT CALL.
8660: # I
8661: # I
8662: # +---+ THIS NODE (P$PAC) SAVES THE CURSOR,
8663: # I C I----- A PTR TO ITSELF, THE CURSOR (COPY)
8664: # +---+ AND A PTR TO NDPAD ON THE STACK.
8665: #
8666: #
8667: # THE FUNCTION OF THE MATCH ROUTINE FOR NDPAB (P$PAB)
8668: # IS SIMPLY TO UNSTACK ITSELF AND FAIL BACK ONTO THE STACK.
8669: #
8670: # THE MATCH ROUTINE FOR P$PAC ALSO SETS THE GLOBAL PATTERN
8671: # FLAG PMDFL NON-ZERO TO INDICATE THAT PATTERN ASSIGNMENTS
8672: # MAY HAVE OCCURED IN THE PATTERN MATCH
8673: #
8674: # IF PMDFL IS SET AT THE END OF THE MATCH (SEE P$NTH), THE
8675: # HISTORY STACK IS SCANNED FOR MATCHING NDPAB-NDPAD PAIRS
8676: # AND THE CORRESPONDING PATTERN ASSIGNMENTS ARE EXECUTED.
8677: #
8678: # THE FUNCTION OF THE MATCH ROUTINE FOR NDPAD (P$PAD)
8679: # IS SIMPLY TO REMOVE ITS ENTRY FROM THE STACK AND FAIL.
8680: # THIS INCLUDES REMOVING THE SPECIAL NODE POINTER STORED
8681: # IN ADDITION TO THE STANDARD TWO ENTRIES ON THE STACK.
8682: #page
8683: #
8684: # COMPOUNT PATTERN STRUCTURES (CONTINUED)
8685: #
8686: # FENCE (FUNCTION)
8687: # ----------------
8688: #
8689: # +---+ THIS NODE (P$FNA) SAVES THE
8690: # I A I CURRENT HISTORY STACK AND A
8691: # +---+ POINTER TO NDFNB ON THE STACK.
8692: # I
8693: # I
8694: # +---+ THIS IS THE PATTERN STRUCTURE
8695: # I X I GIVEN AS THE ARGUMENT TO THE
8696: # +---+ FENCE FUNCTION.
8697: # I
8698: # I
8699: # +---+ THIS NODE P$FNC RESTORES THE OUTER
8700: # I C I HISTORY STACK PTR SAVED IN P$FNA,
8701: # +---+ AND STACKS THE INNER STACK BASE
8702: # PTR AND A POINTER TO NDFND ON THE
8703: # STACK.
8704: #
8705: # NDFNB (F$FNB) SIMPLY IS THE FAILURE EXIT FOR PATTERN
8706: # ARGUMENT FAILURE, AND IT POPS ITSELF AND FAILS ONTO THE
8707: # STACK.
8708: #
8709: # THE MATCH ROUTINE P$FNC ALLOWS FOR AN OPTIMIZATION WHEN
8710: # THE FENCE PATTERN LEAVES NO ALTERNATIVES. IN THIS CASE,
8711: # THE NDFNB ENTRY IS POPPED, AND THE MATCH CONTINUES.
8712: #
8713: # NDFND (P$FND) IS ENTERED WHEN THE PATTERN FAILS AFTER
8714: # GOING THROUGH A NON-OPTIMIZED P$FNC, AND IT POPS THE
8715: # STACK BACK PAST THE INNTER STACK BASE CREATED BY P$FNA
8716: #page
8717: #
8718: # COMPOUND PATTERNS (CONTINUED)
8719: #
8720: # EXPRESSION PATTERNS (RECURSIVE PATTERN MATCHES)
8721: # -----------------------------------------------
8722: #
8723: # INITIAL ENTRY FOR A PATTERN NODE IS TO THE ROUTINE P$EXA.
8724: # IF THE EVALUATED RESULT OF THE EXPRESSION IS ITSELF A
8725: # PATTERN, THEN THE FOLLOWING STEPS ARE TAKEN TO ARRANGE
8726: # FOR PROPER RECURSIVE PROCESSING.
8727: #
8728: # 1) A POINTER TO THE CURRENT NODE (THE P$EXA NODE) IS
8729: # STORED ON THE HISTORY STACK WITH A DUMMY CURSOR.
8730: #
8731: # 2) A SPECIAL HISTORY STACK ENTRY IS MADE IN WHICH THE
8732: # NODE POINTER POINTS TO NDEXB, AND THE CURSOR VALUE
8733: # IS THE SAVED VALUE OF PMHBS ON ENTRY TO THIS NODE.
8734: # THE MATCH ROUTINE FOR NDEXB (P$EXB) RESTORES PMHBS
8735: # FROM THIS CURSOR ENTRY, POPS OFF THE P$EXA NODE
8736: # POINTER AND FAILS.
8737: #
8738: # 3) THE RESULTING HISTORY STACK POINTER IS SAVED IN
8739: # PMHBS TO ESTABLISH A NEW LEVEL OF HISTORY STACK.
8740: #
8741: # AFTER MATCHING A PATTERN, THE END OF MATCH ROUTINE GETS
8742: # CONTROL (P$NTH). THIS ROUTINE PROCEEDS AS FOLLOWS.
8743: #
8744: # 1) LOAD THE CURRENT VALUE OF PMHBS AND RECOGNIZE THE
8745: # OUTER LEVEL CASE BY THE FACT THAT THE ASSOCIATED
8746: # CURSOR IN THIS CASE IS THE PATTERN MATCH TYPE CODE
8747: # WHICH IS LESS THAN 3. TERMINATE THE MATCH IN THIS
8748: # CASE AND CONTINUE EXECUTION OF THE PROGRAM.
8749: #
8750: # 2) OTHERWISE MAKE A SPECIAL HISTORY STACK ENTRY IN
8751: # WHICH THE NODE POINTER POINTS TO THE SPECIAL NODE
8752: # NDEXC AND THE CURSOR IS THE CURRENT VALUE OF PMHBS.
8753: # THE MATCH ROUTINE FOR NDEXC (P$EXC) RESETS PMHBS TO
8754: # THIS (INNER) VALUE AND AND THEN FAILS.
8755: #
8756: # 3) USING THE HISTORY STACK ENTRY MADE ON STARTING THE
8757: # EXPRESSION (ACCESSIBLE WITH THE CURRENT VALUE OF
8758: # PMHBS), RESTORE THE P$EXA NODE POINTER AND THE OLD
8759: # PMHBS SETTING. TAKE THE SUCCESSOR AND CONTINUE.
8760: #
8761: # AN OPTIMIZATION IS POSSIBLE IF THE EXPRESSION PATTERN
8762: # MAKES NO ENTRIES ON THE HISTORY STACK. IN THIS CASE,
8763: # INSTEAD OF BUILDING THE P$EXC NODE IN STEP 2, IT IS MORE
8764: # EFFICIENT TO SIMPLY POP OFF THE P$EXB ENTRY AND ITS
8765: # ASSOCIATED NODE POINTER. THE EFFECT IS THE SAME.
8766: #page
8767: #
8768: # COMPOUND PATTERNS (CONTINUED)
8769: #
8770: # BINARY DOLLAR (IMMEDIATE ASSIGNMENT)
8771: # ------------------------------------
8772: #
8773: # +---+ THIS NODE (P$IMA) STACKS THE CURSOR
8774: # I A I PMHBS AND A PTR TO NDIMB AND RESETS
8775: # +---+ THE STACK PTR PMHBS.
8776: # I
8777: # I
8778: # +---+ THIS IS THE LEFT STRUCTURE FOR THE
8779: # I X I PATTERN LEFT ARGUMENT OF THE
8780: # +---+ IMMEDIATE ASSIGNMENT CALL.
8781: # I
8782: # I
8783: # +---+ THIS NODE (P$IMC) PERFORMS THE
8784: # I C I----- ASSIGNMENT, POPS PMHBS AND STACKS
8785: # +---+ THE OLD PMHBS AND A PTR TO NDIMD.
8786: #
8787: #
8788: # THE STRUCTURE AND EXECUTION OF THIS PATTERN ARE SIMILAR
8789: # TO THOSE OF THE RECURSIVE EXPRESSION PATTERN MATCHING.
8790: #
8791: # THE MATCH ROUTINE FOR NDIMB (P$IMB) RESTORES THE OUTER
8792: # LEVEL VALUE OF PMHBS, UNSTACKS THE SAVED CURSOR AND FAILS
8793: #
8794: # THE MATCH ROUTINE P$IMC USES THE CURRENT VALUE OF PMHBS
8795: # TO LOCATE THE P$IMB ENTRY. THIS ENTRY IS USED TO MAKE
8796: # THE ASSIGNMENT AND RESTORE THE OUTER LEVEL VALUE OF
8797: # PMHBS. FINALLY, THE INNER LEVEL VALUE OF PMHBS AND A
8798: # POINTER TO THE SPECIAL NODE NDIMD ARE STACKED.
8799: #
8800: # THE MATCH ROUTINE FOR NDIMD (P$IMD) RESTORES THE INNER
8801: # LEVEL VALUE OF PMHBS AND FAILS BACK INTO THE STACK.
8802: #
8803: # AN OPTIMIZATION OCCURS IF THE INNER PATTERN MAKES NO
8804: # ENTRIES ON THE HISTORY STACK. IN THIS CASE, P$IMC POPS
8805: # THE P$IMB ENTRY INSTEAD OF MAKING A P$IMD ENTRY.
8806: #page
8807: #
8808: # ARBNO
8809: #
8810: # SEE COMPOUND PATTERNS SECTION FOR STUCTURE AND
8811: # ALGORITHM FOR MATCHING THIS NODE TYPE.
8812: #
8813: # NO PARAMETERS
8814: #
8815: .align 2
8816: .word bl$p0
8817: p$aba: # p0blk
8818: movl r7,-(sp) # stack cursor
8819: movl r9,-(sp) # stack dummy node ptr
8820: movl pmhbs,-(sp) # stack old stack base ptr
8821: movl $ndabb,-(sp) # stack ptr to node ndabb
8822: movl sp,pmhbs # store new stack base ptr
8823: jmp succp # succeed
8824: #page
8825: #
8826: # ARBNO (REMOVE P$ABA SPECIAL STACK ENTRY)
8827: #
8828: # NO PARAMETERS (DUMMY PATTERN)
8829: #
8830: p$abb: # entry point
8831: movl r7,pmhbs # restore history stack base ptr
8832: jmp flpop # fail and pop dummy node ptr
8833: #page
8834: #
8835: # ARBNO (CHECK IF ARG MATCHED NULL STRING)
8836: #
8837: # NO PARAMETERS (DUMMY PATTERN)
8838: #
8839: .align 2
8840: .word bl$p0
8841: p$abc: # p0blk
8842: movl pmhbs,r10 # keep p$abb stack base
8843: movl 4*3(r10),r6 # load initial cursor
8844: movl 4*1(r10),pmhbs # restore outer stack base ptr
8845: cmpl r10,sp # jump if no history stack entries
8846: beqlu pabc1
8847: movl r10,-(sp) # else save inner pmhbs entry
8848: movl $ndabd,-(sp) # stack ptr to special node ndabd
8849: jmp pabc2 # merge
8850: #
8851: # OPTIMISE CASE OF NO EXTRA ENTRIES ON STACK FROM ARBNO ARG
8852: #
8853: pabc1: addl2 $4*num04,sp # remove ndabb entry and cursor
8854: #
8855: # MERGE TO CHECK FOR MATCHING OF NULL STRING
8856: #
8857: pabc2: cmpl r6,r7 # allow further attempt if non-null
8858: beqlu 0f
8859: jmp succp
8860: 0:
8861: movl 4*pthen(r9),r9 # bypass alternative node so as to ..
8862: jmp succp # ... refuse further match attempts
8863: #page
8864: #
8865: # ARBNO (TRY FOR ALTERNATIVES IN ARBNO ARGUMENT)
8866: #
8867: # NO PARAMETERS (DUMMY PATTERN)
8868: #
8869: p$abd: # entry point
8870: movl r7,pmhbs # restore inner stack base ptr
8871: jmp failp # and fail
8872: #page
8873: #
8874: # ABORT
8875: #
8876: # NO PARAMETERS
8877: #
8878: .align 2
8879: .word bl$p0
8880: p$abo: # p0blk
8881: jmp exfal # signal statement failure
8882: #page
8883: #
8884: # ALTERNATION
8885: #
8886: # PARM1 ALTERNATIVE NODE
8887: #
8888: .align 2
8889: .word bl$p1
8890: p$alt: # p1blk
8891: movl r7,-(sp) # stack cursor
8892: movl 4*parm1(r9),-(sp)# stack pointer to alternative
8893: jsb sbchk # check for stack overflow
8894: jmp succp # if all ok, then succeed
8895: #page
8896: #
8897: # ANY (ONE CHARACTER ARGUMENT) (1-CHAR STRING ALSO)
8898: #
8899: # PARM1 CHARACTER ARGUMENT
8900: #
8901: .align 2
8902: .word bl$p1
8903: p$ans: # p1blk
8904: cmpl r7,pmssl # fail if no chars left
8905: bnequ 0f
8906: jmp failp
8907: 0:
8908: movl r$pms,r10 # else point to subject string
8909: movab cfp$f(r10)[r7],r10 # point to current character
8910: movzbl (r10),r6 # load current character
8911: cmpl r6,4*parm1(r9) # fail if no match
8912: beqlu 0f
8913: jmp failp
8914: 0:
8915: incl r7 # else bump cursor
8916: jmp succp # and succeed
8917: #page
8918: #
8919: # ANY (MULTI-CHARACTER ARGUMENT CASE)
8920: #
8921: # PARM1 POINTER TO CTBLK
8922: # PARM2 BIT MASK TO SELECT BIT IN CTBLK
8923: #
8924: .align 2
8925: .word bl$p2
8926: p$any: # p2blk
8927: #
8928: # EXPRESSION ARGUMENT CASE MERGES HERE
8929: #
8930: pany1: cmpl r7,pmssl # fail if no characters left
8931: bnequ 0f
8932: jmp failp
8933: 0:
8934: movl r$pms,r10 # else point to subject string
8935: movab cfp$f(r10)[r7],r10 # get char ptr to current character
8936: movzbl (r10),r6 # load current character
8937: movl 4*parm1(r9),r10 # point to ctblk
8938: moval 0[r6],r6 # change to byte offset
8939: addl2 r6,r10 # point to entry in ctblk
8940: movl 4*ctchs(r10),r6 # load word from ctblk
8941: mcoml 4*parm2(r9),r11 # and with selected bit
8942: bicl2 r11,r6
8943: tstl r6 # fail if no match
8944: bnequ 0f
8945: jmp failp
8946: 0:
8947: incl r7 # else bump cursor
8948: jmp succp # and succeed
8949: #page
8950: #
8951: # ANY (EXPRESSION ARGUMENT)
8952: #
8953: # PARM1 EXPRESSION POINTER
8954: #
8955: .align 2
8956: .word bl$p1
8957: p$ayd: # p1blk
8958: jsb evals # evaluate string argument
8959: .long er_043 # any evaluated argument is not string
8960: .long failp # fail if evaluation failure
8961: .long pany1 # merge multi-char case if ok
8962: #page
8963: #
8964: # P$ARB INITIAL ARB MATCH
8965: #
8966: # NO PARAMETERS
8967: #
8968: # THE P$ARB NODE IS PART OF A COMPOUND PATTERN STRUCTURE
8969: # FOR AN ARB PATTERN (SEE DESCRIPTION OF COMPOUND PATTERNS)
8970: #
8971: .align 2
8972: .word bl$p0
8973: p$arb: # p0blk
8974: movl 4*pthen(r9),r9 # load successor pointer
8975: movl r7,-(sp) # stack dummy cursor
8976: movl r9,-(sp) # stack successor pointer
8977: movl r7,-(sp) # stack cursor
8978: movl $ndarc,-(sp) # stack ptr to special node ndarc
8979: movl (r9),r11 # execute next node matching null
8980: jmp (r11)
8981: #page
8982: #
8983: # P$ARC EXTEND ARB MATCH
8984: #
8985: # NO PARAMETERS (DUMMY PATTERN)
8986: #
8987: p$arc: # entry point
8988: cmpl r7,pmssl # fail and pop stack to successor
8989: bnequ 0f
8990: jmp flpop
8991: 0:
8992: incl r7 # else bump cursor
8993: movl r7,-(sp) # stack updated cursor
8994: movl r9,-(sp) # restack pointer to ndarc node
8995: movl 4*2(sp),r9 # load successor pointer
8996: movl (r9),r11 # off to reexecute successor node
8997: jmp (r11)
8998: #page
8999: #
9000: # BAL
9001: #
9002: # NO PARAMETERS
9003: #
9004: # THE P$BAL NODE IS PART OF THE COMPOUND STRUCTURE BUILT
9005: # FOR BAL (SEE SECTION ON COMPOUND PATTERNS).
9006: #
9007: .align 2
9008: .word bl$p0
9009: p$bal: # p0blk
9010: clrl r8 # zero parentheses level counter
9011: movl r$pms,r10 # point to subject string
9012: movab cfp$f(r10)[r7],r10 # point to current character
9013: jmp pbal2 # jump into scan loop
9014: #
9015: # LOOP TO SCAN OUT CHARACTERS
9016: #
9017: pbal1: movzbl (r10)+,r6 # load next character, bump pointer
9018: incl r7 # push cursor for character
9019: cmpl r6,$ch$pp # jump if left paren
9020: beqlu pbal3
9021: cmpl r6,$ch$rp # jump if right paren
9022: beqlu pbal4
9023: tstl r8 # else succeed if at outer level
9024: beqlu pbal5
9025: #
9026: # HERE AFTER PROCESSING ONE CHARACTER
9027: #
9028: pbal2: cmpl r7,pmssl # loop back unless end of string
9029: bnequ pbal1
9030: jmp failp # in which case, fail
9031: #
9032: # HERE ON LEFT PAREN
9033: #
9034: pbal3: incl r8 # bump paren level
9035: jmp pbal2 # loop back to check end of string
9036: #
9037: # HERE FOR RIGHT PAREN
9038: #
9039: pbal4: tstl r8 # fail if no matching left paren
9040: bnequ 0f
9041: jmp failp
9042: 0:
9043: decl r8 # else decrement level counter
9044: tstl r8 # loop back if not at outer level
9045: bnequ pbal2
9046: #
9047: # HERE AFTER SUCCESSFULLY SCANNING A BALANCED STRING
9048: #
9049: pbal5: movl r7,-(sp) # stack cursor
9050: movl r9,-(sp) # stack ptr to bal node for extend
9051: jmp succp # and succeed
9052: #page
9053: #
9054: # BREAK (EXPRESSION ARGUMENT)
9055: #
9056: # PARM1 EXPRESSION POINTER
9057: #
9058: .align 2
9059: .word bl$p1
9060: p$bkd: # p1blk
9061: jsb evals # evaluate string expression
9062: .long er_044 # break evaluated argument is not string
9063: .long failp # fail if evaluation fails
9064: .long pbrk1 # merge with multi-char case if ok
9065: #page
9066: #
9067: # BREAK (ONE CHARACTER ARGUMENT)
9068: #
9069: # PARM1 CHARACTER ARGUMENT
9070: #
9071: .align 2
9072: .word bl$p1
9073: p$bks: # p1blk
9074: movl pmssl,r8 # get subject string length
9075: subl2 r7,r8 # get number of characters left
9076: tstl r8 # fail if no characters left
9077: bnequ 0f
9078: jmp failp
9079: 0:
9080: # set counter for chars left
9081: movl r$pms,r10 # point to subject string
9082: movab cfp$f(r10)[r7],r10 # point to current character
9083: #
9084: # LOOP TO SCAN TILL BREAK CHARACTER FOUND
9085: #
9086: pbks1: movzbl (r10)+,r6 # load next char, bump pointer
9087: cmpl r6,4*parm1(r9) # succeed if break character found
9088: bnequ 0f
9089: jmp succp
9090: 0:
9091: incl r7 # else push cursor
9092: sobgtr r8,pbks1 # loop back if more to go
9093: jmp failp # fail if end of string, no break chr
9094: #page
9095: #
9096: # BREAK (MULTI-CHARACTER ARGUMENT)
9097: #
9098: # PARM1 POINTER TO CTBLK
9099: # PARM2 BIT MASK TO SELECT BIT COLUMN
9100: #
9101: .align 2
9102: .word bl$p2
9103: p$brk: # p2blk
9104: #
9105: # EXPRESSION ARGUMENT MERGES HERE
9106: #
9107: pbrk1: movl pmssl,r8 # load subject string length
9108: subl2 r7,r8 # get number of characters left
9109: tstl r8 # fail if no characters left
9110: bnequ 0f
9111: jmp failp
9112: 0:
9113: # set counter for characters left
9114: movl r$pms,r10 # else point to subject string
9115: movab cfp$f(r10)[r7],r10 # point to current character
9116: movl r9,psave # save node pointer
9117: #
9118: # LOOP TO SEARCH FOR BREAK CHARACTER
9119: #
9120: pbrk2: movzbl (r10)+,r6 # load next char, bump pointer
9121: movl 4*parm1(r9),r9 # load pointer to ctblk
9122: moval 0[r6],r6 # convert to byte offset
9123: addl2 r6,r9 # point to ctblk entry
9124: movl 4*ctchs(r9),r6 # load ctblk word
9125: movl psave,r9 # restore node pointer
9126: mcoml 4*parm2(r9),r11 # and with selected bit
9127: bicl2 r11,r6
9128: tstl r6 # succeed if break character found
9129: beqlu 0f
9130: jmp succp
9131: 0:
9132: incl r7 # else push cursor
9133: sobgtr r8,pbrk2 # loop back unless end of string
9134: jmp failp # fail if end of string, no break chr
9135: #page
9136: #
9137: # BREAKX (EXTENSION)
9138: #
9139: # THIS IS THE ENTRY WHICH CAUSES AN EXTENSION OF A BREAKX
9140: # MATCH WHEN FAILURE OCCURS. SEE SECTION ON COMPOUND
9141: # PATTERNS FOR FULL DETAILS OF BREAKX MATCHING.
9142: #
9143: # NO PARAMETERS
9144: #
9145: .align 2
9146: .word bl$p0
9147: p$bkx: # p0blk
9148: incl r7 # step cursor past previous break chr
9149: jmp succp # succeed to rematch break
9150: #page
9151: #
9152: # BREAKX (EXPRESSION ARGUMENT)
9153: #
9154: # SEE SECTION ON COMPOUND PATTERNS FOR FULL STRUCTURE OF
9155: # BREAKX PATTERN. THE ACTUAL CHARACTER MATCHING USES A
9156: # BREAK NODE. HOWEVER, THE ENTRY FOR THE EXPRESSION
9157: # ARGUMENT CASE IS SEPARATED TO GET PROPER ERROR MESSAGES.
9158: #
9159: # PARM1 EXPRESSION POINTER
9160: #
9161: .align 2
9162: .word bl$p1
9163: p$bxd: # p1blk
9164: jsb evals # evaluate string argument
9165: .long er_045 # breakx evaluated argument is not string
9166: .long failp # fail if evaluation fails
9167: .long pbrk1 # merge with break if all ok
9168: #page
9169: #
9170: # CURSOR ASSIGNMENT
9171: #
9172: # PARM1 NAME BASE
9173: # PARM2 NAME OFFSET
9174: #
9175: .align 2
9176: .word bl$p2
9177: p$cas: # p2blk
9178: movl r9,-(sp) # save node pointer
9179: movl r7,-(sp) # save cursor
9180: movl 4*parm1(r9),r10 # load name base
9181: movl r7,r5 # load cursor as integer
9182: movl 4*parm2(r9),r7 # load name offset
9183: jsb icbld # get icblk for cursor value
9184: movl r7,r6 # move name offset
9185: movl r9,r7 # move value to assign
9186: jsb asinp # perform assignment
9187: .long flpop # fail on assignment failure
9188: movl (sp)+,r7 # else restore cursor
9189: movl (sp)+,r9 # restore node pointer
9190: jmp succp # and succeed matching null
9191: #page
9192: #
9193: # EXPRESSION NODE (P$EXA, INITIAL ENTRY)
9194: #
9195: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9196: # ALGORITHMS FOR HANDLING EXPRESSION NODES.
9197: #
9198: # PARM1 EXPRESSION POINTER
9199: #
9200: .align 2
9201: .word bl$p1
9202: p$exa: # p1blk
9203: jsb evalp # evaluate expression
9204: .long failp # fail if evaluation fails
9205: cmpl r6,$p$aaa # jump if result is not a pattern
9206: blequ pexa1
9207: #
9208: # HERE IF RESULT OF EXPRESSION IS A PATTERN
9209: #
9210: movl r7,-(sp) # stack dummy cursor
9211: movl r9,-(sp) # stack ptr to p$exa node
9212: movl pmhbs,-(sp) # stack history stack base ptr
9213: movl $ndexb,-(sp) # stack ptr to special node ndexb
9214: movl sp,pmhbs # store new stack base pointer
9215: movl r10,r9 # copy node pointer
9216: movl (r9),r11 # match first node in expression pat
9217: jmp (r11)
9218: #
9219: # HERE IF RESULT OF EXPRESSION IS NOT A PATTERN
9220: #
9221: pexa1: cmpl r6,$b$scl # jump if it is already a string
9222: beqlu pexa2
9223: movl r10,-(sp) # else stack result
9224: movl r9,r10 # save node pointer
9225: jsb gtstg # convert result to string
9226: .long er_046 # expression does not evaluate to pattern
9227: movl r9,r8 # copy string pointer
9228: movl r10,r9 # restore node pointer
9229: movl r8,r10 # copy string pointer again
9230: #
9231: # MERGE HERE WITH STRING POINTER IN XL
9232: #
9233: pexa2: tstl 4*sclen(r10) # just succeed if null string
9234: bnequ 0f
9235: jmp succp
9236: 0:
9237: jmp pstr1 # else merge with string circuit
9238: #page
9239: #
9240: # EXPRESSION NODE (P$EXB, REMOVE NDEXB ENTRY)
9241: #
9242: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9243: # ALGORITHMS FOR HANDLING EXPRESSION NODES.
9244: #
9245: # NO PARAMETERS (DUMMY PATTERN)
9246: #
9247: p$exb: # entry point
9248: movl r7,pmhbs # restore outer level stack pointer
9249: jmp flpop # fail and pop p$exa node ptr
9250: #page
9251: #
9252: # EXPRESSION NODE (P$EXC, REMOVE NDEXC ENTRY)
9253: #
9254: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9255: # ALGORITHMS FOR HANDLING EXPRESSION NODES.
9256: #
9257: # NO PARAMETERS (DUMMY PATTERN)
9258: #
9259: p$exc: # entry point
9260: movl r7,pmhbs # restore inner stack base pointer
9261: jmp failp # and fail into expr pattern alternvs
9262: #page
9263: #
9264: # FAIL
9265: #
9266: # NO PARAMETERS
9267: #
9268: .align 2
9269: .word bl$p0
9270: p$fal: # p0blk
9271: jmp failp # just signal failure
9272: #page
9273: #
9274: # FENCE
9275: #
9276: # SEE COMPOUND PATTERNS SECTION FOR THE STRUCTURE AND
9277: # ALGORITHM FOR MATCHING THIS NODE TYPE.
9278: #
9279: # NO PARAMETERS
9280: #
9281: .align 2
9282: .word bl$p0
9283: p$fen: # p0blk
9284: movl r7,-(sp) # stack dummy cursor
9285: movl $ndabo,-(sp) # stack ptr to abort node
9286: jmp succp # and succeed matching null
9287: #page
9288: #
9289: # FENCE (FUNCTION)
9290: #
9291: # SEE COMPOUND PATTERNS COMMENTS AT START OF THIS SECTION
9292: # FOR DETAILS OF SCHEME
9293: #
9294: # NO PARAMETERS
9295: #
9296: .align 2
9297: .word bl$p0
9298: p$fna: # p0blk
9299: movl pmhbs,-(sp) # stack current history stack base
9300: movl $ndfnb,-(sp) # stack indir ptr to p$fnb (failure)
9301: movl sp,pmhbs # begin new history stack
9302: jmp succp # succeed
9303: #page
9304: #
9305: # FENCE (FUNCTION) (RESET HISTORY STACK AND FAIL)
9306: #
9307: # NO PARAMETERS (DUMMY PATTERN)
9308: #
9309: .align 2
9310: .word bl$p0
9311: p$fnb: # p0blk
9312: movl r7,pmhbs # restore outer pmhbs stack base
9313: jmp failp # ...and fail
9314: #page
9315: #
9316: # FENCE (FUNCTION) (MAKE FENCE TRAP ENTRY ON STACK)
9317: #
9318: # NO PARAMETERS (DUMMY PATTERN)
9319: #
9320: .align 2
9321: .word bl$p0
9322: p$fnc: # p0blk
9323: movl pmhbs,r10 # get inner stack base ptr
9324: movl 4*num01(r10),pmhbs # restore outer stack base
9325: cmpl r10,sp # optimize if no alternatives
9326: beqlu pfnc1
9327: movl r10,-(sp) # else stack inner stack base
9328: movl $ndfnd,-(sp) # stack ptr to ndfnd
9329: jmp succp # succeed
9330: #
9331: # HERE WHEN FENCE FUNCTION LEFT NOTHING ON THE STACK
9332: #
9333: pfnc1: addl2 $4*num02,sp # pop off p$fnb entry
9334: jmp succp # succeed
9335: #page
9336: #
9337: # FENCE (FUNCTION) (SKIP PAST ALTERNATIVES ON FAILURE)
9338: #
9339: # NO PARAMETERS (DUMMY PATTERN)
9340: #
9341: .align 2
9342: .word bl$p0
9343: p$fnd: # p0blk
9344: movl r7,sp # pop stack to fence() history base
9345: jmp flpop # pop base entry and fail
9346: #page
9347: #
9348: # IMMEDIATE ASSIGNMENT (INITIAL ENTRY, SAVE CURRENT CURSOR)
9349: #
9350: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
9351: # STRUCTURE AND ALGORITHM FOR MATCHING THIS NODE TYPE.
9352: #
9353: # NO PARAMETERS
9354: #
9355: .align 2
9356: .word bl$p0
9357: p$ima: # p0blk
9358: movl r7,-(sp) # stack cursor
9359: movl r9,-(sp) # stack dummy node pointer
9360: movl pmhbs,-(sp) # stack old stack base pointer
9361: movl $ndimb,-(sp) # stack ptr to special node ndimb
9362: movl sp,pmhbs # store new stack base pointer
9363: jmp succp # and succeed
9364: #page
9365: #
9366: # IMMEDIATE ASSIGNMENT (REMOVE CURSOR MARK ENTRY)
9367: #
9368: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
9369: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
9370: #
9371: # NO PARAMETERS (DUMMY PATTERN)
9372: #
9373: p$imb: # entry point
9374: movl r7,pmhbs # restore history stack base ptr
9375: jmp flpop # fail and pop dummy node ptr
9376: #page
9377: #
9378: # IMMEDIATE ASSIGNMENT (PERFORM ACTUAL ASSIGNMENT)
9379: #
9380: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
9381: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
9382: #
9383: # PARM1 NAME BASE OF VARIABLE
9384: # PARM2 NAME OFFSET OF VARIABLE
9385: #
9386: .align 2
9387: .word bl$p2
9388: p$imc: # p2blk
9389: movl pmhbs,r10 # load pointer to p$imb entry
9390: movl r7,r6 # copy final cursor
9391: movl 4*3(r10),r7 # load initial cursor
9392: movl 4*1(r10),pmhbs # restore outer stack base pointer
9393: cmpl r10,sp # jump if no history stack entries
9394: beqlu pimc1
9395: movl r10,-(sp) # else save inner pmhbs pointer
9396: movl $ndimd,-(sp) # and a ptr to special node ndimd
9397: jmp pimc2 # merge
9398: #
9399: # HERE IF NO ENTRIES MADE ON HISTORY STACK
9400: #
9401: pimc1: addl2 $4*num04,sp # remove ndimb entry and cursor
9402: #
9403: # MERGE HERE TO PERFORM ASSIGNMENT
9404: #
9405: pimc2: movl r6,-(sp) # save current (final) cursor
9406: movl r9,-(sp) # save current node pointer
9407: movl r$pms,r10 # point to subject string
9408: subl2 r7,r6 # compute substring length
9409: jsb sbstr # build substring
9410: movl r9,r7 # move result
9411: movl (sp),r9 # reload node pointer
9412: movl 4*parm1(r9),r10 # load name base
9413: movl 4*parm2(r9),r6 # load name offset
9414: jsb asinp # perform assignment
9415: .long flpop # fail if assignment fails
9416: movl (sp)+,r9 # else restore node pointer
9417: movl (sp)+,r7 # restore cursor
9418: jmp succp # and succeed
9419: #page
9420: #
9421: # IMMEDIATE ASSIGNMENT (REMOVE NDIMD ENTRY ON FAILURE)
9422: #
9423: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
9424: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
9425: #
9426: # NO PARAMETERS (DUMMY PATTERN)
9427: #
9428: p$imd: # entry point
9429: movl r7,pmhbs # restore inner stack base pointer
9430: jmp failp # and fail
9431: #page
9432: #
9433: # LEN (INTEGER ARGUMENT)
9434: #
9435: # PARM1 INTEGER ARGUMENT
9436: #
9437: .align 2
9438: .word bl$p1
9439: p$len: # p1blk
9440: #
9441: # EXPRESSION ARGUMENT CASE MERGES HERE
9442: #
9443: plen1: addl2 4*parm1(r9),r7 # push cursor indicated amount
9444: cmpl r7,pmssl # succeed if not off end
9445: bgtru 0f
9446: jmp succp
9447: 0:
9448: jmp failp # else fail
9449: #page
9450: #
9451: # LEN (EXPRESSION ARGUMENT)
9452: #
9453: # PARM1 EXPRESSION POINTER
9454: #
9455: .align 2
9456: .word bl$p1
9457: p$lnd: # p1blk
9458: jsb evali # evaluate integer argument
9459: .long er_047 # len evaluated argument is not integer
9460: .long er_048 # len evaluated argument is negative or too large
9461: .long failp # fail if evaluation fails
9462: .long plen1 # merge with normal circuit if ok
9463: #page
9464: #
9465: # NOTANY (EXPRESSION ARGUMENT)
9466: #
9467: # PARM1 EXPRESSION POINTER
9468: #
9469: .align 2
9470: .word bl$p1
9471: p$nad: # p1blk
9472: jsb evals # evaluate string argument
9473: .long er_049 # notany evaluated argument is not string
9474: .long failp # fail if evaluation fails
9475: .long pnay1 # merge with multi-char case if ok
9476: #page
9477: #
9478: # NOTANY (ONE CHARACTER ARGUMENT)
9479: #
9480: # PARM1 CHARACTER ARGUMENT
9481: #
9482: .align 2
9483: .word bl$p1
9484: p$nas: # entry point
9485: cmpl r7,pmssl # fail if no chars left
9486: bnequ 0f
9487: jmp failp
9488: 0:
9489: movl r$pms,r10 # else point to subject string
9490: movab cfp$f(r10)[r7],r10 # point to current character in strin
9491: movzbl (r10),r6 # load current character
9492: cmpl r6,4*parm1(r9) # fail if match
9493: bnequ 0f
9494: jmp failp
9495: 0:
9496: incl r7 # else bump cursor
9497: jmp succp # and succeed
9498: #page
9499: #
9500: # NOTANY (MULTI-CHARACTER STRING ARGUMENT)
9501: #
9502: # PARM1 POINTER TO CTBLK
9503: # PARM2 BIT MASK TO SELECT BIT COLUMN
9504: #
9505: .align 2
9506: .word bl$p2
9507: p$nay: # p2blk
9508: #
9509: # EXPRESSION ARGUMENT CASE MERGES HERE
9510: #
9511: pnay1: cmpl r7,pmssl # fail if no characters left
9512: bnequ 0f
9513: jmp failp
9514: 0:
9515: movl r$pms,r10 # else point to subject string
9516: movab cfp$f(r10)[r7],r10 # point to current character
9517: movzbl (r10),r6 # load current character
9518: moval 0[r6],r6 # convert to byte offset
9519: movl 4*parm1(r9),r10 # load pointer to ctblk
9520: addl2 r6,r10 # point to entry in ctblk
9521: movl 4*ctchs(r10),r6 # load entry from ctblk
9522: mcoml 4*parm2(r9),r11 # and with selected bit
9523: bicl2 r11,r6
9524: tstl r6 # fail if character is matched
9525: beqlu 0f
9526: jmp failp
9527: 0:
9528: incl r7 # else bump cursor
9529: jmp succp # and succeed
9530: #page
9531: #
9532: # END OF PATTERN MATCH
9533: #
9534: # THIS ROUTINE IS ENTERED ON SUCCESSFUL COMPLETION.
9535: # SEE DESCRIPTION OF EXPRESSION PATTERNS IN COMPOUND
9536: # PATTERN SECTION FOR HANDLING OF RECURSION IN MATCHING.
9537: #
9538: # NO PARAMETERS (DUMMY PATTERN)
9539: #
9540: p$nth: # entry point
9541: movl pmhbs,r10 # load pointer to base of stack
9542: movl 4*1(r10),r6 # load saved pmhbs (or pattern type)
9543: cmpl r6,$num02 # jump if outer level (pattern type)
9544: blequ pnth2
9545: #
9546: # HERE WE ARE AT THE END OF MATCHING AN EXPRESSION PATTERN
9547: #
9548: movl r6,pmhbs # restore outer stack base pointer
9549: movl 4*2(r10),r9 # restore pointer to p$exa node
9550: cmpl r10,sp # jump if no history stack entries
9551: beqlu pnth1
9552: movl r10,-(sp) # else stack inner stack base ptr
9553: movl $ndexc,-(sp) # stack ptr to special node ndexc
9554: jmp succp # and succeed
9555: #
9556: # HERE IF NO HISTORY STACK ENTRIES DURING PATTERN
9557: #
9558: pnth1: addl2 $4*num04,sp # remove p$exb entry and node ptr
9559: jmp succp # and succeed
9560: #
9561: # HERE IF END OF MATCH AT OUTER LEVEL
9562: #
9563: pnth2: movl r7,pmssl # save final cursor in safe place
9564: tstl pmdfl # jump if no pattern assignments
9565: beqlu pnth6
9566: #page
9567: #
9568: # END OF PATTERN MATCH (CONTINUED)
9569: #
9570: # NOW WE MUST PERFORM PATTERN ASSIGNMENTS. THIS IS DONE BY
9571: # SCANNING THE HISTORY STACK FOR MATCHING NDPAB-NDPAD PAIRS
9572: #
9573: pnth3: subl2 $4,r10 # point past cursor entry
9574: movl -(r10),r6 # load node pointer
9575: cmpl r6,$ndpad # jump if ndpad entry
9576: beqlu pnth4
9577: cmpl r6,$ndpab # jump if not ndpab entry
9578: bnequ pnth5
9579: #
9580: # HERE FOR NDPAB ENTRY, STACK INITIAL CURSOR
9581: # NOTE THAT THERE MUST BE MORE ENTRIES ON THE STACK.
9582: #
9583: movl 4*1(r10),-(sp) # stack initial cursor
9584: jsb sbchk # check for stack overflow
9585: jmp pnth3 # loop back if ok
9586: #
9587: # HERE FOR NDPAD ENTRY. THE STARTING CURSOR FROM THE
9588: # MATCHING NDPAD ENTRY IS NOW THE TOP STACK ENTRY.
9589: #
9590: pnth4: movl 4*1(r10),r6 # load final cursor
9591: movl (sp),r7 # load initial cursor from stack
9592: movl r10,(sp) # save history stack scan ptr
9593: subl2 r7,r6 # compute length of string
9594: #
9595: # BUILD SUBSTRING AND PERFORM ASSIGNMENT
9596: #
9597: movl r$pms,r10 # point to subject string
9598: jsb sbstr # construct substring
9599: movl r9,r7 # copy substring pointer
9600: movl (sp),r10 # reload history stack scan ptr
9601: movl 4*2(r10),r10 # load pointer to p$pac node with nam
9602: movl 4*parm2(r10),r6 # load name offset
9603: movl 4*parm1(r10),r10# load name base
9604: jsb asinp # perform assignment
9605: .long exfal # match fails if name eval fails
9606: movl (sp)+,r10 # else restore history stack ptr
9607: #page
9608: #
9609: # END OF PATTERN MATCH (CONTINUED)
9610: #
9611: # HERE CHECK FOR END OF ENTRIES
9612: #
9613: pnth5: cmpl r10,sp # loop if more entries to scan
9614: bnequ pnth3
9615: #
9616: # HERE AFTER DEALING WITH PATTERN ASSIGNMENTS
9617: #
9618: pnth6: movl pmhbs,sp # wipe out history stack
9619: movl (sp)+,r7 # load initial cursor
9620: movl (sp)+,r8 # load match type code
9621: movl pmssl,r6 # load final cursor value
9622: movl r$pms,r10 # point to subject string
9623: clrl r$pms # clear subject string ptr for gbcol
9624: tstl r8 # jump if call by name
9625: beqlu pnth7
9626: cmpl r8,$num02 # exit if statement level call
9627: bnequ 0f
9628: jmp exits
9629: 0:
9630: #
9631: # HERE WE HAVE A CALL BY VALUE, BUILD SUBSTRING
9632: #
9633: subl2 r7,r6 # compute length of string
9634: jsb sbstr # build substring
9635: jmp exixr # and exit with substring value
9636: #
9637: # HERE FOR CALL BY NAME, MAKE STACK ENTRIES FOR O$RPL
9638: #
9639: pnth7: movl r7,-(sp) # stack initial cursor
9640: movl r6,-(sp) # stack final cursor
9641: tstl r$pmb # skip if subject not buffer
9642: beqlu pnth8
9643: movl r$pmb,r10 # else get ptr to bcblk instead
9644: #
9645: # HERE WITH XL POINTING TO SCBLK OR BCBLK
9646: #
9647: pnth8: movl r10,-(sp) # stack subject pointer
9648: jmp exits # exit with special entry on stack
9649: #page
9650: #
9651: # POS (INTEGER ARGUMENT)
9652: #
9653: # PARM1 INTEGER ARGUMENT
9654: #
9655: .align 2
9656: .word bl$p1
9657: p$pos: # p1blk
9658: #
9659: # EXPRESSION ARGUMENT CASE MERGES HERE
9660: #
9661: ppos1: cmpl r7,4*parm1(r9) # succeed if at right location
9662: bnequ 0f
9663: jmp succp
9664: 0:
9665: jmp failp # else fail
9666: #page
9667: #
9668: # POS (EXPRESSION ARGUMENT)
9669: #
9670: # PARM1 EXPRESSION POINTER
9671: #
9672: .align 2
9673: .word bl$p1
9674: p$psd: # p1blk
9675: jsb evali # evaluate integer argument
9676: .long er_050 # pos evaluated argument is not integer
9677: .long er_051 # pos evaluated argument is negative or too large
9678: .long failp # fail if evaluation fails
9679: .long ppos1 # merge with normal case if ok
9680: #page
9681: #
9682: # PATTERN ASSIGNMENT (INITIAL ENTRY, SAVE CURSOR)
9683: #
9684: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9685: # ALGORITHMS FOR MATCHING THIS NODE TYPE.
9686: #
9687: # NO PARAMETERS
9688: #
9689: .align 2
9690: .word bl$p0
9691: p$paa: # p0blk
9692: movl r7,-(sp) # stack initial cursor
9693: movl $ndpab,-(sp) # stack ptr to ndpab special node
9694: jmp succp # and succeed matching null
9695: #page
9696: #
9697: # PATTERN ASSIGNMENT (REMOVE SAVED CURSOR)
9698: #
9699: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9700: # ALGORITHMS FOR MATCHING THIS NODE TYPE.
9701: #
9702: # NO PARAMETERS (DUMMY PATTERN)
9703: #
9704: p$pab: # entry point
9705: jmp failp # just fail (entry is already popped)
9706: #page
9707: #
9708: # PATTERN ASSIGNMENT (END OF MATCH, MAKE ASSIGN ENTRY)
9709: #
9710: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9711: # ALGORITHMS FOR MATCHING THIS NODE TYPE.
9712: #
9713: # PARM1 NAME BASE OF VARIABLE
9714: # PARM2 NAME OFFSET OF VARIABLE
9715: #
9716: .align 2
9717: .word bl$p2
9718: p$pac: # p2blk
9719: movl r7,-(sp) # stack dummy cursor value
9720: movl r9,-(sp) # stack pointer to p$pac node
9721: movl r7,-(sp) # stack final cursor
9722: movl $ndpad,-(sp) # stack ptr to special ndpad node
9723: movl sp,pmdfl # set dot flag non-zero
9724: jmp succp # and succeed
9725: #page
9726: #
9727: # PATTERN ASSIGNMENT (REMOVE ASSIGN ENTRY)
9728: #
9729: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9730: # ALGORITHMS FOR MATCHING THIS NODE TYPE.
9731: #
9732: # NO PARAMETERS (DUMMY NODE)
9733: #
9734: p$pad: # entry point
9735: jmp flpop # fail and remove p$pac node
9736: #page
9737: #
9738: # REM
9739: #
9740: # NO PARAMETERS
9741: #
9742: .align 2
9743: .word bl$p0
9744: p$rem: # p0blk
9745: movl pmssl,r7 # point cursor to end of string
9746: jmp succp # and succeed
9747: #page
9748: #
9749: # RPOS (EXPRESSION ARGUMENT)
9750: #
9751: # PARM1 EXPRESSION POINTER
9752: #
9753: .align 2
9754: .word bl$p1
9755: p$rpd: # p1blk
9756: jsb evali # evaluate integer argument
9757: .long er_052 # rpos evaluated argument is not integer
9758: .long er_053 # rpos evaluated argument is negative or too large
9759: .long failp # fail if evaluation fails
9760: .long prps1 # merge with normal case if ok
9761: #page
9762: #
9763: # RPOS (INTEGER ARGUMENT)
9764: #
9765: # PARM1 INTEGER ARGUMENT
9766: #
9767: .align 2
9768: .word bl$p1
9769: p$rps: # p1blk
9770: #
9771: # EXPRESSION ARGUMENT CASE MERGES HERE
9772: #
9773: prps1: movl pmssl,r8 # get length of string
9774: subl2 r7,r8 # get number of characters remaining
9775: cmpl r8,4*parm1(r9) # succeed if at right location
9776: bnequ 0f
9777: jmp succp
9778: 0:
9779: jmp failp # else fail
9780: #page
9781: #
9782: # RTAB (INTEGER ARGUMENT)
9783: #
9784: # PARM1 INTEGER ARGUMENT
9785: #
9786: .align 2
9787: .word bl$p1
9788: p$rtb: # p1blk
9789: #
9790: # EXPRESSION ARGUMENT CASE MERGES HERE
9791: #
9792: prtb1: movl r7,r8 # save initial cursor
9793: movl pmssl,r7 # point to end of string
9794: cmpl r7,4*parm1(r9) # fail if string not long enough
9795: bgequ 0f
9796: jmp failp
9797: 0:
9798: subl2 4*parm1(r9),r7 # else set new cursor
9799: cmpl r7,r8 # and succeed if not too far already
9800: blssu 0f
9801: jmp succp
9802: 0:
9803: jmp failp # in which case, fail
9804: #page
9805: #
9806: # RTAB (EXPRESSION ARGUMENT)
9807: #
9808: # PARM1 EXPRESSION POINTER
9809: #
9810: .align 2
9811: .word bl$p1
9812: p$rtd: # p1blk
9813: jsb evali # evaluate integer argument
9814: .long er_054 # rtab evaluated argument is not integer
9815: .long er_055 # rtab evaluated argument is negative or too large
9816: .long failp # fail if evaluation fails
9817: .long prtb1 # merge with normal case if success
9818: #page
9819: #
9820: # SPAN (EXPRESSION ARGUMENT)
9821: #
9822: # PARM1 EXPRESSION POINTER
9823: #
9824: .align 2
9825: .word bl$p1
9826: p$spd: # p1blk
9827: jsb evals # evaluate string argument
9828: .long er_056 # span evaluated argument is not string
9829: .long failp # fail if evaluation fails
9830: .long pspn1 # merge with multi-char case if ok
9831: #page
9832: #
9833: # SPAN (MULTI-CHARACTER ARGUMENT CASE)
9834: #
9835: # PARM1 POINTER TO CTBLK
9836: # PARM2 BIT MASK TO SELECT BIT COLUMN
9837: #
9838: .align 2
9839: .word bl$p2
9840: p$spn: # p2blk
9841: #
9842: # EXPRESSION ARGUMENT CASE MERGES HERE
9843: #
9844: pspn1: movl pmssl,r8 # copy subject string length
9845: subl2 r7,r8 # calculate number of characters left
9846: tstl r8 # fail if no characters left
9847: bnequ 0f
9848: jmp failp
9849: 0:
9850: movl r$pms,r10 # point to subject string
9851: movab cfp$f(r10)[r7],r10 # point to current character
9852: movl r7,psavc # save initial cursor
9853: movl r9,psave # save node pointer
9854: # set counter for chars left
9855: #
9856: # LOOP TO SCAN MATCHING CHARACTERS
9857: #
9858: pspn2: movzbl (r10)+,r6 # load next character, bump pointer
9859: moval 0[r6],r6 # convert to byte offset
9860: movl 4*parm1(r9),r9 # point to ctblk
9861: addl2 r6,r9 # point to ctblk entry
9862: movl 4*ctchs(r9),r6 # load ctblk entry
9863: movl psave,r9 # restore node pointer
9864: mcoml 4*parm2(r9),r11 # and with selected bit
9865: bicl2 r11,r6
9866: tstl r6 # jump if no match
9867: beqlu pspn3
9868: incl r7 # else push cursor
9869: sobgtr r8,pspn2 # loop back unless end of string
9870: #
9871: # HERE AFTER SCANNING MATCHING CHARACTERS
9872: #
9873: pspn3: cmpl r7,psavc # succeed if chars matched
9874: beqlu 0f
9875: jmp succp
9876: 0:
9877: jmp failp # else fail if null string matched
9878: #page
9879: #
9880: # SPAN (ONE CHARACTER ARGUMENT)
9881: #
9882: # PARM1 CHARACTER ARGUMENT
9883: #
9884: .align 2
9885: .word bl$p1
9886: p$sps: # p1blk
9887: movl pmssl,r8 # get subject string length
9888: subl2 r7,r8 # calculate number of characters left
9889: tstl r8 # fail if no characters left
9890: bnequ 0f
9891: jmp failp
9892: 0:
9893: movl r$pms,r10 # else point to subject string
9894: movab cfp$f(r10)[r7],r10 # point to current character
9895: movl r7,psavc # save initial cursor
9896: # set counter for characters left
9897: #
9898: # LOOP TO SCAN MATCHING CHARACTERS
9899: #
9900: psps1: movzbl (r10)+,r6 # load next character, bump pointer
9901: cmpl r6,4*parm1(r9) # jump if no match
9902: bnequ psps2
9903: incl r7 # else push cursor
9904: sobgtr r8,psps1 # and loop unless end of string
9905: #
9906: # HERE AFTER SCANNING MATCHING CHARACTERS
9907: #
9908: psps2: cmpl r7,psavc # succeed if chars matched
9909: beqlu 0f
9910: jmp succp
9911: 0:
9912: jmp failp # fail if null string matched
9913: #page
9914: #
9915: # MULTI-CHARACTER STRING
9916: #
9917: # NOTE THAT ONE CHARACTER STRINGS USE THE CIRCUIT FOR
9918: # ONE CHARACTER ANY ARGUMENTS (P$AN1).
9919: #
9920: # PARM1 POINTER TO SCBLK FOR STRING ARG
9921: #
9922: .align 2
9923: .word bl$p1
9924: p$str: # p1blk
9925: movl 4*parm1(r9),r10 # get pointer to string
9926: #
9927: # MERGE HERE AFTER EVALUATING EXPRESSION WITH STRING VALUE
9928: #
9929: pstr1: movl r9,psave # save node pointer
9930: movl r$pms,r9 # load subject string pointer
9931: movab cfp$f(r9)[r7],r9# point to current character
9932: addl2 4*sclen(r10),r7 # compute new cursor position
9933: cmpl r7,pmssl # fail if past end of string
9934: blequ 0f
9935: jmp failp
9936: 0:
9937: movl r7,psavc # save updated cursor
9938: movl 4*sclen(r10),r6 # get number of chars to compare
9939: movab cfp$f(r10),r10 # point to chars of test string
9940: jsb sbcmc # compare, fail if not equal
9941: .long failp
9942: .long failp
9943: movl psave,r9 # if all matched, restore node ptr
9944: movl psavc,r7 # restore updated cursor
9945: jmp succp # and succeed
9946: #page
9947: #
9948: # SUCCEED
9949: #
9950: # SEE SECTION ON COMPOUND PATTERNS FOR DETAILS OF THE
9951: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE
9952: #
9953: # NO PARAMETERS
9954: #
9955: .align 2
9956: .word bl$p0
9957: p$suc: # p0blk
9958: movl r7,-(sp) # stack cursor
9959: movl r9,-(sp) # stack pointer to this node
9960: jmp succp # succeed matching null
9961: #page
9962: #
9963: # TAB (INTEGER ARGUMENT)
9964: #
9965: # PARM1 INTEGER ARGUMENT
9966: #
9967: .align 2
9968: .word bl$p1
9969: p$tab: # p1blk
9970: #
9971: # EXPRESSION ARGUMENT CASE MERGES HERE
9972: #
9973: ptab1: cmpl r7,4*parm1(r9) # fail if too far already
9974: blequ 0f
9975: jmp failp
9976: 0:
9977: movl 4*parm1(r9),r7 # else set new cursor position
9978: cmpl r7,pmssl # succeed if not off end
9979: bgtru 0f
9980: jmp succp
9981: 0:
9982: jmp failp # else fail
9983: #page
9984: #
9985: # TAB (EXPRESSION ARGUMENT)
9986: #
9987: # PARM1 EXPRESSION POINTER
9988: #
9989: .align 2
9990: .word bl$p1
9991: p$tbd: # p1blk
9992: jsb evali # evaluate integer argument
9993: .long er_057 # tab evaluated argument is not integer
9994: .long er_058 # tab evaluated argument is negative or too large
9995: .long failp # fail if evaluation fails
9996: .long ptab1 # merge with normal case if ok
9997: #page
9998: #
9999: # ANCHOR MOVEMENT
10000: #
10001: # NO PARAMETERS (DUMMY NODE)
10002: #
10003: p$una: # entry point
10004: movl r7,r9 # copy initial pattern node pointer
10005: movl (sp),r7 # get initial cursor
10006: cmpl r7,pmssl # match fails if at end of string
10007: bnequ 0f
10008: jmp exfal
10009: 0:
10010: incl r7 # else increment cursor
10011: movl r7,(sp) # store incremented cursor
10012: movl r9,-(sp) # restack initial node ptr
10013: movl $nduna,-(sp) # restack unanchored node
10014: movl (r9),r11 # rematch first node
10015: jmp (r11)
10016: #page
10017: #
10018: # END OF PATTERN MATCH ROUTINES
10019: #
10020: # THE FOLLOWING ENTRY POINT MARKS THE END OF THE PATTERN
10021: # MATCHING ROUTINES AND ALSO THE END OF THE ENTRY POINTS
10022: # REFERENCED FROM THE FIRST WORD OF BLOCKS IN DYNAMIC STORE
10023: #
10024: .align 2
10025: .word bl$$i
10026: p$yyy: # mark last entry in pattern section
10027: #title s p i t b o l -- predefined snobol4 functions
10028: #
10029: # THE FOLLOWING SECTION CONTAINS CODING FOR FUNCTIONS
10030: # WHICH ARE PREDEFINED AND AVAILABLE AT THE SNOBOL LEVEL.
10031: #
10032: # THESE ROUTINES RECEIVE CONTROL DIRECTLY FROM THE CODE OR
10033: # INDIRECTLY THROUGH THE O$FNC, O$FNS OR CFUNC ROUTINES.
10034: # IN BOTH CASES THE CONDITIONS ON ENTRY ARE AS FOLLOWS
10035: #
10036: # THE ARGUMENTS ARE ON THE STACK. THE NUMBER OF ARGUMENTS
10037: # HAS BEEN ADJUSTED TO CORRESPOND TO THE SVBLK SVNAR FIELD.
10038: #
10039: # IN CERTAIN FUNCTIONS THE DIRECT CALL IS NOT PERMITTED
10040: # AND IN THESE INSTANCES WE ALSO HAVE.
10041: #
10042: # (WA) ACTUAL NUMBER OF ARGUMENTS IN CALL
10043: #
10044: # CONTROL RETURNS BY PLACING THE FUNCTION RESULT VALUE ON
10045: # ON THE STACK AND CONTINUING EXECUTION WITH THE NEXT
10046: # WORD FROM THE GENERATED CODE.
10047: #
10048: # THE NAMES OF THE ENTRY POINTS OF THESE FUNCTIONS ARE OF
10049: # THE FORM S$XXX WHERE XXX IS THE THREE LETTER CODE FOR
10050: # THE SYSTEM VARIABLE NAME. THE FUNCTIONS ARE IN ORDER
10051: # ALPHABETICALLY BY THEIR ENTRY NAMES.
10052: #page
10053: #
10054: # ANY
10055: #
10056: s$any: # entry point
10057: movl $p$ans,r7 # set pcode for single char case
10058: movl $p$any,r10 # pcode for multi-char case
10059: movl $p$ayd,r8 # pcode for expression case
10060: jsb patst # call common routine to build node
10061: .long er_059 # any argument is not string or expression
10062: jmp exixr # jump for next code word
10063: #page
10064: #
10065: # APPEND
10066: #
10067: s$apn: # entry point
10068: movl (sp)+,r10 # get append argument
10069: movl (sp)+,r9 # get bcblk
10070: cmpl (r9),$b$bct # ok if first arg is bcblk
10071: beqlu sapn1
10072: jmp er_275 # append first argument is not buffer
10073: #
10074: # HERE TO DO THE APPEND
10075: #
10076: sapn1: jsb apndb # do the append
10077: .long er_276 # append second argument is not string
10078: .long exfal # no room - fail
10079: jmp exnul # exit with null result
10080: #page
10081: #
10082: # APPLY
10083: #
10084: # APPLY DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
10085: # WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
10086: #
10087: s$app: # entry point
10088: tstl r6 # jump if no arguments
10089: beqlu sapp3
10090: decl r6 # else get applied func arg count
10091: movl r6,r7 # copy
10092: moval 0[r7],r7 # convert to bytes
10093: movl sp,r10 # copy stack pointer
10094: addl2 r7,r10 # point to function argument on stack
10095: movl (r10),r9 # load function ptr (apply 1st arg)
10096: tstl r6 # jump if no args for applied func
10097: beqlu sapp2
10098: movl r6,r7 # else set counter for loop
10099: #
10100: # LOOP TO MOVE ARGUMENTS UP ON STACK
10101: #
10102: sapp1: subl2 $4,r10 # point to next argument
10103: movl (r10),4*1(r10) # move argument up
10104: sobgtr r7,sapp1 # loop till all moved
10105: #
10106: # MERGE HERE TO CALL FUNCTION (WA = NUMBER OF ARGUMENTS)
10107: #
10108: sapp2: addl2 $4,sp # adjust stack ptr for apply 1st arg
10109: jsb gtnvr # get variable block addr for func
10110: .long sapp3 # jump if not natural variable
10111: movl 4*vrfnc(r9),r10 # else point to function block
10112: jmp cfunc # go call applied function
10113: #
10114: # HERE FOR INVALID FIRST ARGUMENT
10115: #
10116: sapp3: jmp er_060 # apply first arg is not natural variable name
10117: #page
10118: #
10119: # ARBNO
10120: #
10121: # ARBNO BUILDS A COMPOUND PATTERN. SEE DESCRIPTION AT
10122: # START OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
10123: #
10124: s$abn: # entry point
10125: clrl r9 # set parm1 = 0 for the moment
10126: movl $p$alt,r7 # set pcode for alternative node
10127: jsb pbild # build alternative node
10128: movl r9,r10 # save ptr to alternative pattern
10129: movl $p$abc,r7 # pcode for p$abc
10130: clrl r9 # p0blk
10131: jsb pbild # build p$abc node
10132: movl r10,4*pthen(r9) # put alternative node as successor
10133: movl r10,r6 # remember alternative node pointer
10134: movl r9,r10 # copy p$abc node ptr
10135: movl (sp),r9 # load arbno argument
10136: movl r6,(sp) # stack alternative node pointer
10137: jsb gtpat # get arbno argument as pattern
10138: .long er_061 # arbno argument is not pattern
10139: jsb pconc # concat arg with p$abc node
10140: movl r9,r10 # remember ptr to concd patterns
10141: movl $p$aba,r7 # pcode for p$aba
10142: clrl r9 # p0blk
10143: jsb pbild # build p$aba node
10144: movl r10,4*pthen(r9) # concatenate nodes
10145: movl (sp),r10 # recall ptr to alternative node
10146: movl r9,4*parm1(r10) # point alternative back to argument
10147: jmp exits # jump for next code word
10148: #page
10149: #
10150: # ARG
10151: #
10152: s$arg: # entry point
10153: jsb gtsmi # get second arg as small integer
10154: .long er_062 # arg second argument is not integer
10155: .long exfal # fail if out of range or negative
10156: movl r9,r6 # save argument number
10157: movl (sp)+,r9 # load first argument
10158: jsb gtnvr # locate vrblk
10159: .long sarg1 # jump if not natural variable
10160: movl 4*vrfnc(r9),r9 # else load function block pointer
10161: cmpl (r9),$b$pfc # jump if not program defined
10162: bnequ sarg1
10163: tstl r6 # fail if arg number is zero
10164: bnequ 0f
10165: jmp exfal
10166: 0:
10167: cmpl r6,4*fargs(r9) # fail if arg number is too large
10168: blequ 0f
10169: jmp exfal
10170: 0:
10171: moval 0[r6],r6 # else convert to byte offset
10172: addl2 r6,r9 # point to argument selected
10173: movl 4*pfagb(r9),r9 # load argument vrblk pointer
10174: jmp exvnm # exit to build nmblk
10175: #
10176: # HERE IF 1ST ARGUMENT IS BAD
10177: #
10178: sarg1: jmp er_063 # arg first argument is not program function name
10179: #page
10180: #
10181: # ARRAY
10182: #
10183: s$arr: # entry point
10184: movl (sp)+,r10 # load initial element value
10185: movl (sp)+,r9 # load first argument
10186: jsb gtint # convert first arg to integer
10187: .long sar02 # jump if not integer
10188: #
10189: # HERE FOR INTEGER FIRST ARGUMENT, BUILD VCBLK
10190: #
10191: movl 4*icval(r9),r5 # load integer value
10192: tstl r5 # jump if zero or neg (bad dimension)
10193: bgtr 0f
10194: jmp sar10
10195: 0:
10196: movl r5,r6 # else convert to one word, test ovfl
10197: bgeq 0f
10198: jmp sar11
10199: 0:
10200: movl r6,r7 # copy elements for loop later on
10201: addl2 $vcsi$,r6 # add space for standard fields
10202: moval 0[r6],r6 # convert length to bytes
10203: cmpl r6,mxlen # fail if too large
10204: blssu 0f
10205: jmp sar11
10206: 0:
10207: jsb alloc # allocate space for vcblk
10208: movl $b$vct,(r9) # store type word
10209: movl r6,4*vclen(r9) # set length
10210: movl r10,r8 # copy default value
10211: movl r9,r10 # copy vcblk pointer
10212: addl2 $4*vcvls,r10 # point to first element value
10213: #
10214: # LOOP TO SET VECTOR ELEMENTS TO DEFAULT VALUE
10215: #
10216: sar01: movl r8,(r10)+ # store one value
10217: sobgtr r7,sar01 # loop till all stored
10218: jmp exsid # exit setting idval
10219: #page
10220: #
10221: # ARRAY (CONTINUED)
10222: #
10223: # HERE IF FIRST ARGUMENT IS NOT AN INTEGER
10224: #
10225: sar02: movl r9,-(sp) # replace argument on stack
10226: jsb xscni # initialize scan of first argument
10227: .long er_064 # array first argument is not integer or string
10228: .long exnul # dummy (unused) null string exit
10229: movl r$xsc,-(sp) # save prototype pointer
10230: movl r10,-(sp) # save default value
10231: clrl arcdm # zero count of dimensions
10232: clrl arptr # zero offset to indicate pass one
10233: movl intv1,r5 # load integer one
10234: movl r5,arnel # initialize element count
10235: #
10236: # THE FOLLOWING CODE IS EXECUTED TWICE. THE FIRST TIME
10237: # (ARPTR EQ 0), IT IS USED TO COUNT THE NUMBER OF ELEMENTS
10238: # AND NUMBER OF DIMENSIONS. THE SECOND TIME (ARPTR GT 0) IS
10239: # USED TO ACTUALLY FILL IN THE DIM,LBD FIELDS OF THE ARBLK.
10240: #
10241: sar03: movl intv1,r5 # load one as default low bound
10242: movl r5,arsvl # save as low bound
10243: movl $ch$cl,r8 # set delimiter one = colon
10244: movl $ch$cm,r10 # set delimiter two = comma
10245: jsb xscan # scan next bound
10246: cmpl r6,$num01 # jump if not colon
10247: bnequ sar04
10248: #
10249: # HERE WE HAVE A COLON ENDING A LOW BOUND
10250: #
10251: jsb gtint # convert low bound
10252: .long er_065 # array first argument lower bound is not integer
10253: movl 4*icval(r9),r5 # load value of low bound
10254: movl r5,arsvl # store low bound value
10255: movl $ch$cm,r8 # set delimiter one = comma
10256: movl r8,r10 # and delimiter two = comma
10257: jsb xscan # scan high bound
10258: #page
10259: #
10260: # ARRAY (CONTINUED)
10261: #
10262: # MERGE HERE TO PROCESS UPPER BOUND
10263: #
10264: sar04: jsb gtint # convert high bound to integer
10265: .long er_066 # array first argument upper bound is not integer
10266: movl 4*icval(r9),r5 # get high bound
10267: subl2 arsvl,r5 # subtract lower bound
10268: bvc 0f
10269: jmp sar10
10270: 0:
10271: tstl r5 # bad dimension if negative
10272: bgeq 0f
10273: jmp sar10
10274: 0:
10275: addl2 intv1,r5 # add 1 to get dimension
10276: bvc 0f
10277: jmp sar10
10278: 0:
10279: movl arptr,r10 # load offset (also pass indicator)
10280: tstl r10 # jump if first pass
10281: beqlu sar05
10282: #
10283: # HERE IN SECOND PASS TO STORE LBD AND DIM IN ARBLK
10284: #
10285: addl2 (sp),r10 # point to current location in arblk
10286: movl r5,4*cfp$i(r10) # store dimension
10287: movl arsvl,r5 # load low bound
10288: movl r5,(r10) # store low bound
10289: addl2 $4*ardms,arptr # bump offset to next bounds
10290: jmp sar06 # jump to check for end of bounds
10291: #
10292: # HERE IN PASS 1
10293: #
10294: sar05: incl arcdm # bump dimension count
10295: mull2 arnel,r5 # multiply dimension by count so far
10296: bvc 0f
10297: jmp sar11
10298: 0:
10299: movl r5,arnel # else store updated element count
10300: #
10301: # MERGE HERE AFTER PROCESSING ONE SET OF BOUNDS
10302: #
10303: sar06: tstl r6 # loop back unless end of bounds
10304: beqlu 0f
10305: jmp sar03
10306: 0:
10307: tstl arptr # jump if end of pass 2
10308: beqlu 0f
10309: jmp sar09
10310: 0:
10311: #page
10312: #
10313: # ARRAY (CONTINUED)
10314: #
10315: # HERE AT END OF PASS ONE, BUILD ARBLK
10316: #
10317: movl arnel,r5 # get number of elements
10318: movl r5,r7 # get as addr integer, test ovflo
10319: bgeq 0f
10320: jmp sar11
10321: 0:
10322: moval 0[r7],r7 # else convert to length in bytes
10323: movl $4*arsi$,r6 # set size of standard fields
10324: movl arcdm,r8 # set dimension count to control loop
10325: #
10326: # LOOP TO ALLOW SPACE FOR DIMENSIONS
10327: #
10328: sar07: addl2 $4*ardms,r6 # allow space for one set of bounds
10329: sobgtr r8,sar07 # loop back till all accounted for
10330: movl r6,r10 # save size (=arofs)
10331: #
10332: # NOW ALLOCATE SPACE FOR ARBLK
10333: #
10334: addl2 r7,r6 # add space for elements
10335: addl2 $4,r6 # allow for arpro prototype field
10336: cmpl r6,mxlen # fail if too large
10337: blssu 0f
10338: jmp sar11
10339: 0:
10340: jsb alloc # else allocate arblk
10341: movl (sp),r7 # load default value
10342: movl r9,(sp) # save arblk pointer
10343: movl r6,r8 # save length in bytes
10344: ashl $-2,r6,r6 # convert length back to words
10345: # set counter to control loop
10346: #
10347: # LOOP TO CLEAR ENTIRE ARBLK TO DEFAULT VALUE
10348: #
10349: sar08: movl r7,(r9)+ # set one word
10350: sobgtr r6,sar08 # loop till all set
10351: #page
10352: #
10353: # ARRAY (CONTINUED)
10354: #
10355: # NOW SET INITIAL FIELDS OF ARBLK
10356: #
10357: movl (sp)+,r9 # reload arblk pointer
10358: movl (sp),r7 # load prototype
10359: movl $b$art,(r9) # set type word
10360: movl r8,4*arlen(r9) # store length in bytes
10361: clrl 4*idval(r9) # zero id till we get it built
10362: movl r10,4*arofs(r9) # set prototype field ptr
10363: movl arcdm,4*arndm(r9)# set number of dimensions
10364: movl r9,r8 # save arblk pointer
10365: addl2 r10,r9 # point to prototype field
10366: movl r7,(r9) # store prototype ptr in arblk
10367: movl $4*arlbd,arptr # set offset for pass 2 bounds scan
10368: movl r7,r$xsc # reset string pointer for xscan
10369: movl r8,(sp) # store arblk pointer on stack
10370: clrl xsofs # reset offset ptr to start of string
10371: jmp sar03 # jump back to rescan bounds
10372: #
10373: # HERE AFTER FILLING IN BOUNDS INFORMATION (END PASS TWO)
10374: #
10375: sar09: movl (sp)+,r9 # reload pointer to arblk
10376: jmp exsid # exit setting idval
10377: #
10378: # HERE FOR BAD DIMENSION
10379: #
10380: sar10: jmp er_067 # array dimension is zero,negative or out of range
10381: #
10382: # HERE IF ARRAY IS TOO LARGE
10383: #
10384: sar11: jmp er_068 # array size exceeds maximum permitted
10385: #page
10386: #
10387: # BUFFER
10388: #
10389: s$buf: # entry point
10390: movl (sp)+,r10 # get initial value
10391: movl (sp)+,r9 # get requested allocation
10392: jsb gtint # convert to integer
10393: .long er_269 # buffer first argument is not integer
10394: movl 4*icval(r9),r5 # get value
10395: tstl r5 # branch if negative or zero
10396: bleq sbf01
10397: movl r5,r6 # move with overflow check
10398: bgeq 0f
10399: jmp sbf02
10400: 0:
10401: jsb alobf # allocate the buffer
10402: jsb apndb # copy it in
10403: .long er_270 # buffer second argument is not string or buffer
10404: .long er_271 # buffer initial value too big for allocation
10405: jmp exsid # exit setting idval
10406: #
10407: # HERE FOR INVALID ALLOCATION SIZE
10408: #
10409: sbf01: jmp er_272 # buffer first argument is not positive
10410: #
10411: # HERE FOR ALLOCATION SIZE INTEGER OVERFLOW
10412: #
10413: sbf02: jmp er_273 # buffer size is too big
10414: #page
10415: #
10416: # BREAK
10417: #
10418: s$brk: # entry point
10419: movl $p$bks,r7 # set pcode for single char case
10420: movl $p$brk,r10 # pcode for multi-char case
10421: movl $p$bkd,r8 # pcode for expression case
10422: jsb patst # call common routine to build node
10423: .long er_069 # break argument is not string or expression
10424: jmp exixr # jump for next code word
10425: #page
10426: #
10427: # BREAKX
10428: #
10429: # BREAKX IS A COMPOUND PATTERN. SEE DESCRIPTION AT START
10430: # OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
10431: #
10432: s$bkx: # entry point
10433: movl $p$bks,r7 # pcode for single char argument
10434: movl $p$brk,r10 # pcode for multi-char argument
10435: movl $p$bxd,r8 # pcode for expression case
10436: jsb patst # call common routine to build node
10437: .long er_070 # breakx argument is not string or expression
10438: #
10439: # NOW HOOK BREAKX NODE ON AT FRONT END
10440: #
10441: movl r9,-(sp) # save ptr to break node
10442: movl $p$bkx,r7 # set pcode for breakx node
10443: jsb pbild # build it
10444: movl (sp),4*pthen(r9)# set break node as successor
10445: movl $p$alt,r7 # set pcode for alternation node
10446: jsb pbild # build (parm1=alt=breakx node)
10447: movl r9,r6 # save ptr to alternation node
10448: movl (sp),r9 # point to break node
10449: movl r6,4*pthen(r9) # set alternate node as successor
10450: jmp exits # exit with result on stack
10451: #page
10452: #
10453: # CHAR
10454: #
10455: s$chr: # entry point
10456: jsb gtsmi # convert arg to integer
10457: .long er_281 # char argument not integer
10458: .long schr1 # too big error exit
10459: cmpl r8,$cfp$a # see if out of range of host set
10460: bgequ schr1
10461: movl $num01,r6 # if not set scblk allocation
10462: movl r8,r7 # save char code
10463: jsb alocs # allocate 1 bau scblk
10464: movl r9,r10 # copy scblk pointer
10465: movab cfp$f(r10),r10 # get set to stuff char
10466: movb r7,(r10)+ # stuff it
10467: clrl r10 # clear slop in xl
10468: jmp exixr # exit with scblk pointer
10469: #
10470: # HERE IF CHAR ARGUMENT IS OUT OF RANGE
10471: #
10472: schr1: jmp er_282 # char argument not in range
10473: #page
10474: #
10475: # CLEAR
10476: #
10477: s$clr: # entry point
10478: jsb xscni # initialize to scan argument
10479: .long er_071 # clear argument is not string
10480: .long sclr2 # jump if null
10481: #
10482: # LOOP TO SCAN OUT NAMES IN FIRST ARGUMENT. VARIABLES IN
10483: # THE LIST ARE FALGGED BY SETTING VRGET OF VRBLK TO ZERO.
10484: #
10485: sclr1: movl $ch$cm,r8 # set delimiter one = comma
10486: movl r8,r10 # delimiter two = comma
10487: jsb xscan # scan next variable name
10488: jsb gtnvr # locate vrblk
10489: .long er_072 # clear argument has null variable name
10490: clrl 4*vrget(r9) # else flag by zeroing vrget field
10491: tstl r6 # loop back if stopped by comma
10492: bnequ sclr1
10493: #
10494: # HERE AFTER FLAGGING VARIABLES IN ARGUMENT LIST
10495: #
10496: sclr2: movl hshtb,r7 # point to start of hash table
10497: #
10498: # LOOP THROUGH SLOTS IN HASH TABLE
10499: #
10500: sclr3: cmpl r7,hshte # exit returning null if none left
10501: bnequ 0f
10502: jmp exnul
10503: 0:
10504: movl r7,r9 # else copy slot pointer
10505: addl2 $4,r7 # bump slot pointer
10506: subl2 $4*vrnxt,r9 # set offset to merge into loop
10507: #
10508: # LOOP THROUGH VRBLKS ON ONE HASH CHAIN
10509: #
10510: sclr4: movl 4*vrnxt(r9),r9 # point to next vrblk on chain
10511: tstl r9 # jump for next bucket if chain end
10512: beqlu sclr3
10513: tstl 4*vrget(r9) # jump if not flagged
10514: bnequ sclr5
10515: #page
10516: #
10517: # CLEAR (CONTINUED)
10518: #
10519: # HERE FOR FLAGGED VARIABLE, DO NOT SET VALUE TO NULL
10520: #
10521: jsb setvr # for flagged var, restore vrget
10522: jmp sclr4 # and loop back for next vrblk
10523: #
10524: # HERE TO SET VALUE OF A VARIABLE TO NULL
10525: # PRROTECTED VARIABLES (ARB, ETC) ARE EXEMPT
10526: #
10527: sclr5: cmpl 4*vrsto(r9),$b$vre # check for protected variable (reg05)
10528: beqlu sclr4
10529: movl r9,r10 # copy vrblk pointer (reg05)
10530: #
10531: # LOOP TO LOCATE VALUE AT END OF POSSIBLE TRBLK CHAIN
10532: #
10533: sclr6: movl r10,r6 # save block pointer
10534: movl 4*vrval(r10),r10# load next value field
10535: cmpl (r10),$b$trt # loop back if trapped
10536: beqlu sclr6
10537: #
10538: # NOW STORE THE NULL VALUE
10539: #
10540: movl r6,r10 # restore block pointer
10541: movl $nulls,4*vrval(r10) # store null constant value
10542: jmp sclr4 # loop back for next vrblk
10543: #page
10544: #
10545: # CODE
10546: #
10547: s$cod: # entry point
10548: movl (sp)+,r9 # load argument
10549: jsb gtcod # convert to code
10550: .long exfal # fail if conversion is impossible
10551: jmp exixr # else return code as result
10552: #page
10553: #
10554: # COLLECT
10555: #
10556: s$col: # entry point
10557: movl (sp)+,r9 # load argument
10558: jsb gtint # convert to integer
10559: .long er_073 # collect argument is not integer
10560: movl 4*icval(r9),r5 # load collect argument
10561: movl r5,clsvi # save collect argument
10562: clrl r7 # set no move up
10563: jsb gbcol # perform garbage collection
10564: movl dname,r6 # point to end of memory
10565: subl2 dnamp,r6 # subtract next location
10566: ashl $-2,r6,r6 # convert bytes to words
10567: movl r6,r5 # convert words available as integer
10568: subl2 clsvi,r5 # subtract argument
10569: bvc 0f
10570: jmp exfal
10571: 0:
10572: tstl r5 # fail if not enough
10573: bgeq 0f
10574: jmp exfal
10575: 0:
10576: addl2 clsvi,r5 # else recompute available
10577: jmp exint # and exit with integer result
10578: #page
10579: #
10580: # CONVERT
10581: #
10582: s$cnv: # entry point
10583: jsb gtstg # convert second argument to string
10584: .long er_074 # convert second argument is not string
10585: jsb flstg # fold lower case to upper case
10586: movl (sp),r10 # load first argument
10587: cmpl (r10),$b$pdt # jump if not program defined
10588: bnequ scv01
10589: #
10590: # HERE FOR PROGRAM DEFINED DATATYPE
10591: #
10592: movl 4*pddfp(r10),r10# point to dfblk
10593: movl 4*dfnam(r10),r10# load datatype name
10594: jsb ident # compare with second arg
10595: .long exits # exit if ident with arg as result
10596: jmp exfal # else fail
10597: #
10598: # HERE IF NOT PROGRAM DEFINED DATATYPE
10599: #
10600: scv01: movl r9,-(sp) # save string argument
10601: movl $svctb,r10 # point to table of names to compare
10602: clrl r7 # initialize counter
10603: movl r6,r8 # save length of argument string
10604: #
10605: # LOOP THROUGH TABLE ENTRIES
10606: #
10607: scv02: movl (r10)+,r9 # load next table entry, bump pointer
10608: tstl r9 # fail if zero marking end of list
10609: bnequ 0f
10610: jmp exfal
10611: 0:
10612: cmpl r8,4*sclen(r9) # jump if wrong length
10613: beqlu 0f
10614: jmp scv05
10615: 0:
10616: movl r10,cnvtp # else store table pointer
10617: movab cfp$f(r9),r9 # point to chars of table entry
10618: movl (sp),r10 # load pointer to string argument
10619: movab cfp$f(r10),r10 # point to chars of string arg
10620: movl r8,r6 # set number of chars to compare
10621: jsb sbcmc # compare, jump if no match
10622: .long scv04
10623: .long scv04
10624: #page
10625: #
10626: # CONVERT (CONTINUED)
10627: #
10628: # HERE WE HAVE A MATCH
10629: #
10630: scv03: movl r7,r10 # copy entry number
10631: addl2 $4,sp # pop string arg off stack
10632: movl (sp)+,r9 # load first argument
10633: casel r10,$0,$cnvtt # jump to appropriate routine
10634: 5:
10635: .word scv06-5b # string
10636: .word scv07-5b # integer
10637: .word scv09-5b # name
10638: .word scv10-5b # pattern
10639: .word scv11-5b # array
10640: .word scv19-5b # table
10641: .word scv25-5b # expression
10642: .word scv26-5b # code
10643: .word scv27-5b # numeric
10644: .word scv08-5b # real
10645: .word scv28-5b # buffer
10646: #esw # end of switch table
10647: #
10648: # HERE IF NO MATCH WITH TABLE ENTRY
10649: #
10650: scv04: movl cnvtp,r10 # restore table pointer, merge
10651: #
10652: # MERGE HERE IF LENGTHS DID NOT MATCH
10653: #
10654: scv05: incl r7 # bump entry number
10655: jmp scv02 # loop back to check next entry
10656: #
10657: # HERE TO CONVERT TO STRING
10658: #
10659: scv06: movl r9,-(sp) # replace string argument on stack
10660: jsb gtstg # convert to string
10661: .long exfal # fail if conversion not possible
10662: jmp exixr # else return string
10663: #page
10664: #
10665: # CONVERT (CONTINUED)
10666: #
10667: # HERE TO CONVERT TO INTEGER
10668: #
10669: scv07: jsb gtint # convert to integer
10670: .long exfal # fail if conversion not possible
10671: jmp exixr # else return integer
10672: #
10673: # HERE TO CONVERT TO REAL
10674: #
10675: scv08: jsb gtrea # convert to real
10676: .long exfal # fail if conversion not possible
10677: jmp exixr # else return real
10678: #
10679: # HERE TO CONVERT TO NAME
10680: #
10681: scv09: cmpl (r9),$b$nml # return if already a name
10682: bnequ 0f
10683: jmp exixr
10684: 0:
10685: jsb gtnvr # else try string to name convert
10686: .long exfal # fail if conversion not possible
10687: jmp exvnm # else exit building nmblk for vrblk
10688: #
10689: # HERE TO CONVERT TO PATTERN
10690: #
10691: scv10: jsb gtpat # convert to pattern
10692: .long exfal # fail if conversion not possible
10693: jmp exixr # else return pattern
10694: #
10695: # CONVERT TO ARRAY
10696: #
10697: scv11: jsb gtarr # get an array
10698: .long exfal # fail if not convertible
10699: jmp exsid # exit setting id field
10700: #
10701: # CONVERT TO TABLE
10702: #
10703: scv19: movl (r9),r6 # load first word of block
10704: movl r9,-(sp) # replace arblk pointer on stack
10705: cmpl r6,$b$tbt # return arg if already a table
10706: bnequ 0f
10707: jmp exits
10708: 0:
10709: cmpl r6,$b$art # else fail if not an array
10710: beqlu 0f
10711: jmp exfal
10712: 0:
10713: #page
10714: #
10715: # CONVERT (CONTINUED)
10716: #
10717: # HERE TO CONVERT AN ARRAY TO TABLE
10718: #
10719: cmpl 4*arndm(r9),$num02 # fail if not 2-dim array
10720: beqlu 0f
10721: jmp exfal
10722: 0:
10723: movl 4*ardm2(r9),r5 # load dim 2
10724: subl2 intv2,r5 # subtract 2 to compare
10725: tstl r5 # fail if dim2 not 2
10726: beql 0f
10727: jmp exfal
10728: 0:
10729: #
10730: # HERE WE HAVE AN ARBLK OF THE RIGHT SHAPE
10731: #
10732: movl 4*ardim(r9),r5 # load dim 1 (number of elements)
10733: movl r5,r6 # get as one word integer
10734: movl r6,r7 # copy to control loop
10735: addl2 $tbsi$,r6 # add space for standard fields
10736: moval 0[r6],r6 # convert length to bytes
10737: jsb alloc # allocate space for tbblk
10738: movl r9,r8 # copy tbblk pointer
10739: movl r9,-(sp) # save tbblk pointer
10740: movl $b$tbt,(r9)+ # store type word
10741: clrl (r9)+ # store zero for idval for now
10742: movl r6,(r9)+ # store length
10743: movl $nulls,(r9)+ # null initial lookup value
10744: #
10745: # LOOP TO INITIALIZE BUCKET PTRS TO POINT TO TABLE
10746: #
10747: scv20: movl r8,(r9)+ # set bucket ptr to point to tbblk
10748: sobgtr r7,scv20 # loop till all initialized
10749: movl $4*arvl2,r7 # set offset to first arblk element
10750: #
10751: # LOOP TO COPY ELEMENTS FROM ARRAY TO TABLE
10752: #
10753: scv21: movl 4*1(sp),r10 # point to arblk
10754: cmpl r7,4*arlen(r10) # jump if all moved
10755: beqlu scv24
10756: addl2 r7,r10 # else point to current location
10757: addl2 $4*num02,r7 # bump offset
10758: movl (r10),r9 # load subscript name
10759: subl2 $4,r10 # adjust ptr to merge (trval=1+1)
10760: #page
10761: #
10762: # CONVERT (CONTINUED)
10763: #
10764: # LOOP TO CHASE DOWN TRBLK CHAIN FOR VALUE
10765: #
10766: scv22: movl 4*trval(r10),r10# point to next value
10767: cmpl (r10),$b$trt # loop back if trapped
10768: beqlu scv22
10769: #
10770: # HERE WITH NAME IN XR, VALUE IN XL
10771: #
10772: scv23: movl r10,-(sp) # stack value
10773: movl 4*1(sp),r10 # load tbblk pointer
10774: jsb tfind # build teblk (note wb gt 0 by name)
10775: .long exfal # fail if acess fails
10776: movl (sp)+,4*teval(r10) # store value in teblk
10777: jmp scv21 # loop back for next element
10778: #
10779: # HERE AFTER MOVING ALL ELEMENTS TO TBBLK
10780: #
10781: scv24: movl (sp)+,r9 # load tbblk pointer
10782: addl2 $4,sp # pop arblk pointer
10783: jmp exsid # exit setting idval
10784: #
10785: # CONVERT TO EXPRESSION
10786: #
10787: scv25: jsb gtexp # convert to expression
10788: .long exfal # fail if conversion not possible
10789: jmp exixr # else return expression
10790: #
10791: # CONVERT TO CODE
10792: #
10793: scv26: jsb gtcod # convert to code
10794: .long exfal # fail if conversion is not possible
10795: jmp exixr # else return code
10796: #
10797: # CONVERT TO NUMERIC
10798: #
10799: scv27: jsb gtnum # convert to numeric
10800: .long exfal # fail if unconvertible
10801: jmp exixr # return number
10802: #page
10803: #
10804: # CONVERT TO BUFFER
10805: #
10806: scv28: movl r9,-(sp) # stack string for procedure
10807: jsb gtstg # convert to string
10808: .long exfal # fail if conversion not possible
10809: movl r9,r10 # save string pointer
10810: jsb alobf # allocate buffer of same size
10811: jsb apndb # copy in the string
10812: .long invalid$ # already string - cant fail to cnv
10813: .long invalid$ # must be enough room
10814: jmp exsid # exit setting idval field
10815: #page
10816: #
10817: # COPY
10818: #
10819: s$cop: # entry point
10820: jsb copyb # copy the block
10821: .long exits # return if no idval field
10822: jmp exsid # exit setting id value
10823: #page
10824: #
10825: # DATA
10826: #
10827: s$dat: # entry point
10828: jsb xscni # prepare to scan argument
10829: .long er_075 # data argument is not string
10830: .long er_076 # data argument is null
10831: #
10832: # SCAN OUT DATATYPE NAME
10833: #
10834: movl $ch$pp,r8 # delimiter one = left paren
10835: movl r8,r10 # delimiter two = left paren
10836: jsb xscan # scan datatype name
10837: tstl r6 # skip if left paren found
10838: bnequ sdat1
10839: jmp er_077 # data argument is missing a left paren
10840: #
10841: # HERE AFTER SCANNING DATATYPE NAME
10842: #
10843: sdat1: movl 4*sclen(r9),r6 # get length
10844: jsb flstg # fold lower case to upper case
10845: movl r9,r10 # save name ptr
10846: movl 4*sclen(r9),r6 # get length
10847: movab 3+(4*scsi$)(r6),r6 # compute space needed
10848: bicl2 $3,r6
10849: jsb alost # request static store for name
10850: movl r9,-(sp) # save datatype name
10851: jsb sbmvw # copy name to static
10852: movl (sp),r9 # get name ptr
10853: clrl r10 # scrub dud register
10854: jsb gtnvr # locate vrblk for datatype name
10855: .long er_078 # data argument has null datatype name
10856: movl r9,datdv # save vrblk pointer for datatype
10857: movl sp,datxs # store starting stack value
10858: clrl r7 # zero count of field names
10859: #
10860: # LOOP TO SCAN FIELD NAMES AND STACK VRBLK POINTERS
10861: #
10862: sdat2: movl $ch$rp,r8 # delimiter one = right paren
10863: movl $ch$cm,r10 # delimiter two = comma
10864: jsb xscan # scan next field name
10865: tstl r6 # jump if delimiter found
10866: bnequ sdat3
10867: jmp er_079 # data argument is missing a right paren
10868: #
10869: # HERE AFTER SCANNING OUT ONE FIELD NAME
10870: #
10871: sdat3: jsb gtnvr # locate vrblk for field name
10872: .long er_080 # data argument has null field name
10873: movl r9,-(sp) # stack vrblk pointer
10874: incl r7 # increment counter
10875: cmpl r6,$num02 # loop back if stopped by comma
10876: beqlu sdat2
10877: #page
10878: #
10879: # DATA (CONTINUED)
10880: #
10881: # NOW BUILD THE DFBLK
10882: #
10883: movl $dfsi$,r6 # set size of dfblk standard fields
10884: addl2 r7,r6 # add number of fields
10885: moval 0[r6],r6 # convert length to bytes
10886: movl r7,r8 # preserve no. of fields
10887: jsb alost # allocate space for dfblk
10888: movl r8,r7 # get no of fields
10889: movl datxs,r10 # point to start of stack
10890: movl (r10),r8 # load datatype name
10891: movl r9,(r10) # save dfblk pointer on stack
10892: movl $b$dfc,(r9)+ # store type word
10893: movl r7,(r9)+ # store number of fields (fargs)
10894: movl r6,(r9)+ # store length (dflen)
10895: subl2 $4*pddfs,r6 # compute pdblk length (for dfpdl)
10896: movl r6,(r9)+ # store pdblk length (dfpdl)
10897: movl r8,(r9)+ # store datatype name (dfnam)
10898: movl r7,r8 # copy number of fields
10899: #
10900: # LOOP TO MOVE FIELD NAME VRBLK POINTERS TO DFBLK
10901: #
10902: sdat4: movl -(r10),(r9)+ # move one field name vrblk pointer
10903: sobgtr r8,sdat4 # loop till all moved
10904: #
10905: # NOW DEFINE THE DATATYPE FUNCTION
10906: #
10907: movl r6,r8 # copy length of pdblk for later loop
10908: movl datdv,r9 # point to vrblk
10909: movl datxs,r10 # point back on stack
10910: movl (r10),r10 # load dfblk pointer
10911: jsb dffnc # define function
10912: #page
10913: #
10914: # DATA (CONTINUED)
10915: #
10916: # LOOP TO BUILD FFBLKS
10917: #
10918: #
10919: # NOTICE THAT THE FFBLKS ARE CONSTRUCTED IN REVERSE ORDER
10920: # SO THAT THE REQUIRED OFFSETS CAN BE OBTAINED FROM
10921: # SUCCESSIVE DECREMENTATION OF THE PDBLK LENGTH (IN WC).
10922: #
10923: sdat5: movl $4*ffsi$,r6 # set length of ffblk
10924: jsb alloc # allocate space for ffblk
10925: movl $b$ffc,(r9) # set type word
10926: movl $num01,4*fargs(r9) # store fargs (always one)
10927: movl datxs,r10 # point back on stack
10928: movl (r10),4*ffdfp(r9)# copy dfblk ptr to ffblk
10929: subl2 $4,r8 # decrement old dfpdl to get next ofs
10930: movl r8,4*ffofs(r9) # set offset to this field
10931: clrl 4*ffnxt(r9) # tentatively set zero forward ptr
10932: movl r9,r10 # copy ffblk pointer for dffnc
10933: movl (sp),r9 # load vrblk pointer for field
10934: movl 4*vrfnc(r9),r9 # load current function pointer
10935: cmpl (r9),$b$ffc # skip if not currently a field func
10936: bnequ sdat6
10937: #
10938: # HERE WE MUST CHAIN AN OLD FFBLK PTR TO PRESERVE IT IN THE
10939: # CASE OF MULTIPLE FIELD FUNCTIONS WITH THE SAME NAME
10940: #
10941: movl r9,4*ffnxt(r10) # link new ffblk to previous chain
10942: #
10943: # MERGE HERE TO DEFINE FIELD FUNCTION
10944: #
10945: sdat6: movl (sp)+,r9 # load vrblk pointer
10946: jsb dffnc # define field function
10947: cmpl sp,datxs # loop back till all done
10948: bnequ sdat5
10949: addl2 $4,sp # pop dfblk pointer
10950: jmp exnul # return with null result
10951: #page
10952: #
10953: # DATATYPE
10954: #
10955: s$dtp: # entry point
10956: movl (sp)+,r9 # load argument
10957: jsb dtype # get datatype
10958: jmp exixr # and return it as result
10959: #page
10960: #
10961: # DATE
10962: #
10963: s$dte: # entry point
10964: jsb sysdt # call system date routine
10965: movl 4*1(r10),r6 # load length for sbstr
10966: tstl r6 # return null if length is zero
10967: bnequ 0f
10968: jmp exnul
10969: 0:
10970: clrl r7 # set zero offset
10971: jsb sbstr # use sbstr to build scblk
10972: jmp exixr # return date string
10973: #page
10974: #
10975: # DEFINE
10976: #
10977: s$def: # entry point
10978: movl (sp)+,r9 # load second argument
10979: clrl deflb # zero label pointer in case null
10980: cmpl r9,$nulls # jump if null second argument
10981: beqlu sdf01
10982: jsb gtnvr # else find vrblk for label
10983: .long sdf13 # jump if not a variable name
10984: movl r9,deflb # else set specified entry
10985: #
10986: # SCAN FUNCTION NAME
10987: #
10988: sdf01: jsb xscni # prepare to scan first argument
10989: .long er_081 # define first argument is not string
10990: .long er_082 # define first argument is null
10991: movl $ch$pp,r8 # delimiter one = left paren
10992: movl r8,r10 # delimiter two = left paren
10993: jsb xscan # scan out function name
10994: tstl r6 # jump if left paren found
10995: bnequ sdf02
10996: jmp er_083 # define first argument is missing a left paren
10997: #
10998: # HERE AFTER SCANNING OUT FUNCTION NAME
10999: #
11000: sdf02: jsb gtnvr # get variable name
11001: .long er_084 # define first argument has null function name
11002: movl r9,defvr # save vrblk pointer for function nam
11003: clrl r7 # zero count of arguments
11004: movl sp,defxs # save initial stack pointer
11005: tstl deflb # jump if second argument given
11006: bnequ sdf03
11007: movl r9,deflb # else default is function name
11008: #
11009: # LOOP TO SCAN ARGUMENT NAMES AND STACK VRBLK POINTERS
11010: #
11011: sdf03: movl $ch$rp,r8 # delimiter one = right paren
11012: movl $ch$cm,r10 # delimiter two = comma
11013: jsb xscan # scan out next argument name
11014: tstl r6 # skip if delimiter found
11015: bnequ sdf04
11016: jmp er_085 # null arg name or missing ) in define first arg.
11017: #page
11018: #
11019: # DEFINE (CONTINUED)
11020: #
11021: # HERE AFTER SCANNING AN ARGUMENT NAME
11022: #
11023: sdf04: cmpl r9,$nulls # skip if non-null
11024: bnequ sdf05
11025: tstl r7 # ignore null if case of no arguments
11026: beqlu sdf06
11027: #
11028: # HERE AFTER DEALING WITH THE CASE OF NO ARGUMENTS
11029: #
11030: sdf05: jsb gtnvr # get vrblk pointer
11031: .long sdf03 # loop back to ignore null name
11032: movl r9,-(sp) # stack argument vrblk pointer
11033: incl r7 # increment counter
11034: cmpl r6,$num02 # loop back if stopped by a comma
11035: beqlu sdf03
11036: #
11037: # HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES
11038: #
11039: sdf06: movl r7,defna # save number of arguments
11040: clrl r7 # zero count of locals
11041: #
11042: # LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS
11043: #
11044: sdf07: movl $ch$cm,r8 # set delimiter one = comma
11045: movl r8,r10 # set delimiter two = comma
11046: jsb xscan # scan out next local name
11047: cmpl r9,$nulls # skip if non-null
11048: bnequ sdf08
11049: tstl r7 # ignore null if case of no locals
11050: beqlu sdf09
11051: #
11052: # HERE AFTER SCANNING OUT A LOCAL NAME
11053: #
11054: sdf08: jsb gtnvr # get vrblk pointer
11055: .long sdf07 # loop back to ignore null name
11056: incl r7 # if ok, increment count
11057: movl r9,-(sp) # stack vrblk pointer
11058: tstl r6 # loop back if stopped by a comma
11059: bnequ sdf07
11060: #page
11061: #
11062: # DEFINE (CONTINUED)
11063: #
11064: # HERE AFTER SCANNING LOCALS, BUILD PFBLK
11065: #
11066: sdf09: movl r7,r6 # copy count of locals
11067: addl2 defna,r6 # add number of arguments
11068: movl r6,r8 # set sum args+locals as loop count
11069: addl2 $pfsi$,r6 # add space for standard fields
11070: moval 0[r6],r6 # convert length to bytes
11071: jsb alloc # allocate space for pfblk
11072: movl r9,r10 # save pointer to pfblk
11073: movl $b$pfc,(r9)+ # store first word
11074: movl defna,(r9)+ # store number of arguments
11075: movl r6,(r9)+ # store length (pflen)
11076: movl defvr,(r9)+ # store vrblk ptr for function name
11077: movl r7,(r9)+ # store number of locals
11078: clrl (r9)+ # deal with label later
11079: clrl (r9)+ # zero pfctr
11080: clrl (r9)+ # zero pfrtr
11081: tstl r8 # skip if no args or locals
11082: beqlu sdf11
11083: movl r10,r6 # keep pfblk pointer
11084: movl defxs,r10 # point before arguments
11085: # get count of args+locals for loop
11086: #
11087: # LOOP TO MOVE LOCALS AND ARGS TO PFBLK
11088: #
11089: sdf10: movl -(r10),(r9)+ # store one entry and bump pointers
11090: sobgtr r8,sdf10 # loop till all stored
11091: movl r6,r10 # recover pfblk pointer
11092: #page
11093: #
11094: # DEFINE (CONTINUED)
11095: #
11096: # NOW DEAL WITH LABEL
11097: #
11098: sdf11: movl defxs,sp # pop stack
11099: movl deflb,r9 # point to vrblk for label
11100: movl 4*vrlbl(r9),r9 # load label pointer
11101: cmpl (r9),$b$trt # skip if not trapped
11102: bnequ sdf12
11103: movl 4*trlbl(r9),r9 # else point to real label
11104: #
11105: # HERE AFTER LOCATING REAL LABEL POINTER
11106: #
11107: sdf12: cmpl r9,$stndl # jump if label is not defined
11108: beqlu sdf13
11109: movl r9,4*pfcod(r10) # else store label pointer
11110: movl defvr,r9 # point back to vrblk for function
11111: jsb dffnc # define function
11112: jmp exnul # and exit returning null
11113: #
11114: # HERE FOR ERRONEOUS LABEL
11115: #
11116: sdf13: jmp er_086 # define function entry point is not defined label
11117: #page
11118: #
11119: # DETACH
11120: #
11121: s$det: # entry point
11122: movl (sp)+,r9 # load argument
11123: jsb gtvar # locate variable
11124: .long er_087 # detach argument is not appropriate name
11125: jsb dtach # detach i/o association from name
11126: jmp exnul # return null result
11127: #page
11128: #
11129: # DIFFER
11130: #
11131: s$dif: # entry point
11132: movl (sp)+,r9 # load second argument
11133: movl (sp)+,r10 # load first argument
11134: jsb ident # call ident comparison routine
11135: .long exfal # fail if ident
11136: jmp exnul # return null if differ
11137: #page
11138: #
11139: # DUMP
11140: #
11141: s$dmp: # entry point
11142: jsb gtsmi # load dump arg as small integer
11143: .long er_088 # dump argument is not integer
11144: .long er_089 # dump argument is negative or too large
11145: jsb dumpr # else call dump routine
11146: jmp exnul # and return null as result
11147: #page
11148: #
11149: # DUPL
11150: #
11151: s$dup: # entry point
11152: jsb gtsmi # get second argument as small intege
11153: .long er_090 # dupl second argument is not integer
11154: .long sdup7 # jump if negative ot too big
11155: movl r9,r7 # save duplication factor
11156: jsb gtstg # get first arg as string
11157: .long sdup4 # jump if not a string
11158: #
11159: # HERE FOR CASE OF DUPLICATION OF A STRING
11160: #
11161: movl r6,r5 # acquire length as integer
11162: movl r5,dupsi # save for the moment
11163: movl r7,r5 # get duplication factor as integer
11164: mull2 dupsi,r5 # form product
11165: bvs sdup3
11166: tstl r5 # return null if result length = 0
11167: bneq 0f
11168: jmp exnul
11169: 0:
11170: movl r5,r6 # get as addr integer, check ovflo
11171: bgeq 0f
11172: jmp sdup3
11173: 0:
11174: #
11175: # MERGE HERE WITH RESULT LENGTH IN WA
11176: #
11177: sdup1: movl r9,r10 # save string pointer
11178: jsb alocs # allocate space for string
11179: movl r9,-(sp) # save as result pointer
11180: movl r10,r8 # save pointer to argument string
11181: movab cfp$f(r9),r9 # prepare to store chars of result
11182: # set counter to control loop
11183: #
11184: # LOOP THROUGH DUPLICATIONS
11185: #
11186: sdup2: movl r8,r10 # point back to argument string
11187: movl 4*sclen(r10),r6 # get number of characters
11188: movab cfp$f(r10),r10 # point to chars in argument string
11189: jsb sbmvc # move characters to result string
11190: sobgtr r7,sdup2 # loop till all duplications done
11191: jmp exits # then exit for next code word
11192: #page
11193: #
11194: # DUPL (CONTINUED)
11195: #
11196: # HERE IF TOO LARGE, SET MAX LENGTH AND LET ALOCS CATCH IT
11197: #
11198: sdup3: movl dname,r6 # set impossible length for alocs
11199: jmp sdup1 # merge back
11200: #
11201: # HERE IF NOT A STRING
11202: #
11203: sdup4: jsb gtpat # convert argument to pattern
11204: .long er_091 # dupl first argument is not string or pattern
11205: #
11206: # HERE TO DUPLICATE A PATTERN ARGUMENT
11207: #
11208: movl r9,-(sp) # store pattern on stack
11209: movl $ndnth,r9 # start off with null pattern
11210: tstl r7 # null pattern is result if dupfac=0
11211: beqlu sdup6
11212: movl r7,-(sp) # preserve loop count
11213: #
11214: # LOOP TO DUPLICATE BY SUCCESSIVE CONCATENATION
11215: #
11216: sdup5: movl r9,r10 # copy current value as right argumnt
11217: movl 4*1(sp),r9 # get a new copy of left
11218: jsb pconc # concatenate
11219: decl (sp) # count down
11220: tstl (sp) # loop
11221: bnequ sdup5
11222: addl2 $4,sp # pop loop count
11223: #
11224: # HERE TO EXIT AFTER CONSTRUCTING PATTERN
11225: #
11226: sdup6: movl r9,(sp) # store result on stack
11227: jmp exits # exit with result on stack
11228: #
11229: # FAIL IF SECOND ARG IS OUT OF RANGE
11230: #
11231: sdup7: addl2 $4,sp # pop first argument
11232: jmp exfal # fail
11233: #page
11234: #
11235: # EJECT
11236: #
11237: s$ejc: # entry point
11238: jsb iofcb # call fcblk routine
11239: .long er_092 # eject argument is not a suitable name
11240: .long sejc1 # null argument
11241: jsb sysef # call eject file function
11242: .long er_093 # eject file does not exist
11243: .long er_094 # eject file does not permit page eject
11244: .long er_095 # eject caused non-recoverable output error
11245: jmp exnul # return null as result
11246: #
11247: # HERE TO EJECT STANDARD OUTPUT FILE
11248: #
11249: sejc1: jsb sysep # call routine to eject printer
11250: jmp exnul # exit with null result
11251: #page
11252: #
11253: # ENDFILE
11254: #
11255: s$enf: # entry point
11256: jsb iofcb # call fcblk routine
11257: .long er_096 # endfile argument is not a suitable name
11258: .long er_097 # endfile argument is null
11259: jsb sysen # call endfile routine
11260: .long er_098 # endfile file does not exist
11261: .long er_099 # endfile file does not permit endfile
11262: .long er_100 # endfile caused non-recoverable output error
11263: movl r10,r7 # remember vrblk ptr from iofcb call
11264: #
11265: # LOOP TO FIND TRTRF BLOCK
11266: #
11267: senf1: movl r10,r9 # copy pointer
11268: movl 4*trval(r9),r9 # chain along
11269: cmpl (r9),$b$trt # skip out if chain end
11270: beqlu 0f
11271: jmp exnul
11272: 0:
11273: cmpl 4*trtyp(r9),$trtfc # loop if not found
11274: bnequ senf1
11275: movl 4*trval(r9),4*trval(r10) # remove trtrf
11276: movl 4*trtrf(r9),enfch# point to head of iochn
11277: movl 4*trfpt(r9),r8 # point to fcblk
11278: movl r7,r9 # filearg1 vrblk from iofcb
11279: jsb setvr # reset it
11280: movl $r$fcb,r10 # ptr to head of fcblk chain
11281: subl2 $4*num02,r10 # adjust ready to enter loop
11282: #
11283: # FIND FCBLK
11284: #
11285: senf2: movl r10,r9 # copy ptr
11286: movl 4*2(r10),r10 # get next link
11287: tstl r10 # stop if chain end
11288: beqlu senf4
11289: cmpl 4*3(r10),r8 # jump if fcblk found
11290: beqlu senf3
11291: jmp senf2 # loop
11292: #
11293: # REMOVE FCBLK
11294: #
11295: senf3: movl 4*2(r10),4*2(r9)# delete fcblk from chain
11296: #
11297: # LOOP WHICH DETACHES ALL VBLS ON IOCHN CHAIN
11298: #
11299: senf4: movl enfch,r10 # get chain head
11300: tstl r10 # finished if chain end
11301: bnequ 0f
11302: jmp exnul
11303: 0:
11304: movl 4*trtrf(r10),enfch # chain along
11305: movl 4*ionmo(r10),r6 # name offset
11306: movl 4*ionmb(r10),r10# name base
11307: jsb dtach # detach name
11308: jmp senf4 # loop till done
11309: #page
11310: #
11311: # EQ
11312: #
11313: s$eqf: # entry point
11314: jsb acomp # call arithmetic comparison routine
11315: .long er_101 # eq first argument is not numeric
11316: .long er_102 # eq second argument is not numeric
11317: .long exfal # fail if lt
11318: .long exnul # return null if eq
11319: .long exfal # fail if gt
11320: #page
11321: #
11322: # EVAL
11323: #
11324: s$evl: # entry point
11325: movl (sp)+,r9 # load argument
11326: jsb gtexp # convert to expression
11327: .long er_103 # eval argument is not expression
11328: movl (r3)+,r8 # load next code word
11329: cmpl r8,$ofne$ # jump if called by value
11330: bnequ sevl1
11331: movl r3,r10 # copy code pointer
11332: movl (r10),r6 # get next code word
11333: cmpl r6,$ornm$ # by name unless expression
11334: bnequ sevl2
11335: tstl 4*1(sp) # jump if by name
11336: bnequ sevl2
11337: #
11338: # HERE IF CALLED BY VALUE
11339: #
11340: sevl1: clrl r7 # set flag for by value
11341: movl r8,-(sp) # save code word
11342: jsb evalx # evaluate expression by value
11343: .long exfal # fail if evaluation fails
11344: movl r9,r10 # copy result
11345: movl (sp),r9 # reload next code word
11346: movl r10,(sp) # stack result
11347: movl (r9),r11 # jump to execute next code word
11348: jmp (r11)
11349: #
11350: # HERE IF CALLED BY NAME
11351: #
11352: sevl2: movl $num01,r7 # set flag for by name
11353: jsb evalx # evaluate expression by name
11354: .long exfal # fail if evaluation fails
11355: jmp exnam # exit with name
11356: #page
11357: #
11358: # EXIT
11359: #
11360: s$ext: # entry point
11361: clrl r7 # clear amount of static shift
11362: jsb gbcol # compact memory by collecting
11363: jsb gtstg # convert arg to string
11364: .long er_104 # exit argument is not suitable integer or string
11365: movl r9,r10 # copy string ptr
11366: jsb gtint # check it is integer
11367: .long sext1 # skip if unconvertible
11368: clrl r10 # note it is integer
11369: movl 4*icval(r9),r5 # get integer arg
11370: movl r$fcb,r7 # get fcblk chain header
11371: #
11372: # MERGE TO CALL OSINT EXIT ROUTINE
11373: #
11374: sext1: movl $headv,r9 # point to v.v string
11375: jsb sysxi # call external routine
11376: .long er_105 # exit action not available in this implementation
11377: .long er_106 # exit action caused irrecoverable error
11378: tstl r5 # return if argument 0
11379: bneq 0f
11380: jmp exnul
11381: 0:
11382: clrl gbcnt # resuming execution so reset
11383: tstl r5 # skip if positive
11384: bgtr sext2
11385: mnegl r5,r5 # make positive
11386: #
11387: # CHECK FOR OPTION RESPECIFICATION
11388: #
11389: sext2: movl r5,r8 # get value in work reg
11390: cmpl r8,$num03 # skip if was 3
11391: beqlu sext3
11392: movl r8,-(sp) # save value
11393: clrl r8 # set to read options
11394: jsb prpar # read syspp options
11395: movl (sp)+,r8 # restore value
11396: #
11397: # DEAL WITH HEADER OPTION (FIDDLED BY PRPAR)
11398: #
11399: sext3: movl sp,headp # assume no headers
11400: cmpl r8,$num01 # skip if not 1
11401: bnequ sext4
11402: clrl headp # request header printing
11403: #
11404: # ALMOST READY TO RESUME RUNNING
11405: #
11406: sext4: jsb systm # get execution time start (sgd11)
11407: movl r5,timsx # save as initial time
11408: movl kvstc,r5 # reset to ensure ...
11409: movl r5,kvstl # ... correct execution stats
11410: jmp exnul # resume execution
11411: #page
11412: #
11413: # FIELD
11414: #
11415: s$fld: # entry point
11416: jsb gtsmi # get second argument (field number)
11417: .long er_107 # field second argument is not integer
11418: .long exfal # fail if out of range
11419: movl r9,r7 # else save integer value
11420: movl (sp)+,r9 # load first argument
11421: jsb gtnvr # point to vrblk
11422: .long sfld1 # jump (error) if not variable name
11423: movl 4*vrfnc(r9),r9 # else point to function block
11424: cmpl (r9),$b$dfc # error if not datatype function
11425: bnequ sfld1
11426: #
11427: # HERE IF FIRST ARGUMENT IS A DATATYPE FUNCTION NAME
11428: #
11429: tstl r7 # fail if argument number is zero
11430: bnequ 0f
11431: jmp exfal
11432: 0:
11433: cmpl r7,4*fargs(r9) # fail if too large
11434: blequ 0f
11435: jmp exfal
11436: 0:
11437: moval 0[r7],r7 # else convert to byte offset
11438: addl2 r7,r9 # point to field name
11439: movl 4*dfflb(r9),r9 # load vrblk pointer
11440: jmp exvnm # exit to build nmblk
11441: #
11442: # HERE FOR BAD FIRST ARGUMENT
11443: #
11444: sfld1: jmp er_108 # field first argument is not datatype name
11445: #page
11446: #
11447: # FENCE
11448: #
11449: s$fnc: # entry point
11450: movl $p$fnc,r7 # set pcode for p$fnc
11451: clrl r9 # p0blk
11452: jsb pbild # build p$fnc node
11453: movl r9,r10 # save pointer to it
11454: movl (sp)+,r9 # get argument
11455: jsb gtpat # convert to pattern
11456: .long er_259 # fence argument is not pattern
11457: jsb pconc # concatenate to p$fnc node
11458: movl r9,r10 # save ptr to concatenated pattern
11459: movl $p$fna,r7 # set for p$fna pcode
11460: clrl r9 # p0blk
11461: jsb pbild # construct p$fna node
11462: movl r10,4*pthen(r9) # set pattern as pthen
11463: movl r9,-(sp) # set as result
11464: jmp exits # do next code word
11465: #page
11466: #
11467: # GE
11468: #
11469: s$gef: # entry point
11470: jsb acomp # call arithmetic comparison routine
11471: .long er_109 # ge first argument is not numeric
11472: .long er_110 # ge second argument is not numeric
11473: .long exfal # fail if lt
11474: .long exnul # return null if eq
11475: .long exnul # return null if gt
11476: #page
11477: #
11478: # GT
11479: #
11480: s$gtf: # entry point
11481: jsb acomp # call arithmetic comparison routine
11482: .long er_111 # gt first argument is not numeric
11483: .long er_112 # gt second argument is not numeric
11484: .long exfal # fail if lt
11485: .long exfal # fail if eq
11486: .long exnul # return null if gt
11487: #page
11488: #
11489: # HOST
11490: #
11491: s$hst: # entry point
11492: movl (sp)+,r9 # get third arg
11493: movl (sp)+,r10 # get second arg
11494: movl (sp)+,r6 # get first arg
11495: jsb syshs # enter syshs routine
11496: .long er_254 # erroneous argument for host
11497: .long er_255 # error during execution of host
11498: .long shst1 # store host string
11499: .long exnul # return null result
11500: .long exixr # return xr
11501: .long exfal # fail return
11502: #
11503: # RETURN HOST STRING
11504: #
11505: shst1: tstl r10 # null string if syshs uncooperative
11506: bnequ 0f
11507: jmp exnul
11508: 0:
11509: movl 4*sclen(r10),r6 # length
11510: clrl r7 # zero offset
11511: jsb sbstr # build copy of string
11512: movl r9,-(sp) # stack the result
11513: jmp exits # return result on stack
11514: #page
11515: #
11516: # IDENT
11517: #
11518: s$idn: # entry point
11519: movl (sp)+,r9 # load second argument
11520: movl (sp)+,r10 # load first argument
11521: jsb ident # call ident comparison routine
11522: .long exnul # return null if ident
11523: jmp exfal # fail if differ
11524: #page
11525: #
11526: # INPUT
11527: #
11528: s$inp: # entry point
11529: clrl r7 # input flag
11530: jsb ioput # call input/output assoc. routine
11531: .long er_113 # input third argument is not a string
11532: .long er_114 # inappropriate second argument for input
11533: .long er_115 # inappropriate first argument for input
11534: .long er_116 # inappropriate file specification for input
11535: .long exfal # fail if file does not exist
11536: .long er_117 # input file cannot be read
11537: jmp exnul # return null string
11538: #page
11539: #
11540: # INSERT
11541: #
11542: s$ins: # entry point
11543: movl (sp)+,r10 # get string arg
11544: jsb gtsmi # get replace length
11545: .long er_277 # insert third argument not integer
11546: .long exfal # fail if out of range
11547: movl r8,r7 # copy to proper reg
11548: jsb gtsmi # get replace position
11549: .long er_278 # insert second argument not integer
11550: .long exfal # fail if out of range
11551: tstl r8 # fail if zero
11552: bnequ 0f
11553: jmp exfal
11554: 0:
11555: decl r8 # decrement to get offset
11556: movl r8,r6 # put in proper register
11557: movl (sp)+,r9 # get buffer
11558: cmpl (r9),$b$bct # press on if type ok
11559: beqlu sins1
11560: jmp er_279 # insert first argument not buffer
11561: #
11562: # HERE WHEN EVERYTHING LOADED UP
11563: #
11564: sins1: jsb insbf # call to insert
11565: .long er_280 # insert fourth argument not a string
11566: .long exfal # fail if out of range
11567: jmp exnul # else ok - exit with null
11568: #page
11569: #
11570: # INTEGER
11571: #
11572: s$int: # entry point
11573: movl (sp)+,r9 # load argument
11574: jsb gtnum # convert to numeric
11575: .long exfal # fail if non-numeric
11576: cmpl r6,$b$icl # return null if integer
11577: bnequ 0f
11578: jmp exnul
11579: 0:
11580: jmp exfal # fail if real
11581: #page
11582: #
11583: # ITEM
11584: #
11585: # ITEM DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
11586: # WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
11587: #
11588: s$itm: # entry point
11589: #
11590: # DEAL WITH CASE OF NO ARGS
11591: #
11592: tstl r6 # jump if at least one arg
11593: bnequ sitm1
11594: movl $nulls,-(sp) # else supply garbage null arg
11595: movl $num01,r6 # and fix argument count
11596: #
11597: # CHECK FOR NAME/VALUE CASES
11598: #
11599: sitm1: movl r3,r9 # get current code pointer
11600: movl (r9),r10 # load next code word
11601: decl r6 # get number of subscripts
11602: movl r6,r9 # copy for arref
11603: cmpl r10,$ofne$ # jump if called by name
11604: beqlu sitm2
11605: #
11606: # HERE IF CALLED BY VALUE
11607: #
11608: clrl r7 # set code for call by value
11609: jmp arref # off to array reference routine
11610: #
11611: # HERE FOR CALL BY NAME
11612: #
11613: sitm2: movl sp,r7 # set code for call by name
11614: movl (r3)+,r6 # load and ignore ofne$ call
11615: jmp arref # off to array reference routine
11616: #page
11617: #
11618: # LE
11619: #
11620: s$lef: # entry point
11621: jsb acomp # call arithmetic comparison routine
11622: .long er_118 # le first argument is not numeric
11623: .long er_119 # le second argument is not numeric
11624: .long exnul # return null if lt
11625: .long exnul # return null if eq
11626: .long exfal # fail if gt
11627: #page
11628: #
11629: # LEN
11630: #
11631: s$len: # entry point
11632: movl $p$len,r7 # set pcode for integer arg case
11633: movl $p$lnd,r6 # set pcode for expr arg case
11634: jsb patin # call common routine to build node
11635: .long er_120 # len argument is not integer or expression
11636: .long er_121 # len argument is negative or too large
11637: jmp exixr # return pattern node
11638: #page
11639: #
11640: # LEQ
11641: #
11642: s$leq: # entry point
11643: jsb lcomp # call string comparison routine
11644: .long er_122 # leq first argument is not string
11645: .long er_123 # leq second argument is not string
11646: .long exfal # fail if llt
11647: .long exnul # return null if leq
11648: .long exfal # fail if lgt
11649: #page
11650: #
11651: # LGE
11652: #
11653: s$lge: # entry point
11654: jsb lcomp # call string comparison routine
11655: .long er_124 # lge first argument is not string
11656: .long er_125 # lge second argument is not string
11657: .long exfal # fail if llt
11658: .long exnul # return null if leq
11659: .long exnul # return null if lgt
11660: #page
11661: #
11662: # LGT
11663: #
11664: s$lgt: # entry point
11665: jsb lcomp # call string comparison routine
11666: .long er_126 # lgt first argument is not string
11667: .long er_127 # lgt second argument is not string
11668: .long exfal # fail if llt
11669: .long exfal # fail if leq
11670: .long exnul # return null if lgt
11671: #page
11672: #
11673: # LLE
11674: #
11675: s$lle: # entry point
11676: jsb lcomp # call string comparison routine
11677: .long er_128 # lle first argument is not string
11678: .long er_129 # lle second argument is not string
11679: .long exnul # return null if llt
11680: .long exnul # return null if leq
11681: .long exfal # fail if lgt
11682: #page
11683: #
11684: # LLT
11685: #
11686: s$llt: # entry point
11687: jsb lcomp # call string comparison routine
11688: .long er_130 # llt first argument is not string
11689: .long er_131 # llt second argument is not string
11690: .long exnul # return null if llt
11691: .long exfal # fail if leq
11692: .long exfal # fail if lgt
11693: #page
11694: #
11695: # LNE
11696: #
11697: s$lne: # entry point
11698: jsb lcomp # call string comparison routine
11699: .long er_132 # lne first argument is not string
11700: .long er_133 # lne second argument is not string
11701: .long exnul # return null if llt
11702: .long exfal # fail if leq
11703: .long exnul # return null if lgt
11704: #page
11705: #
11706: # LOCAL
11707: #
11708: s$loc: # entry point
11709: jsb gtsmi # get second argument (local number)
11710: .long er_134 # local second argument is not integer
11711: .long exfal # fail if out of range
11712: movl r9,r7 # save local number
11713: movl (sp)+,r9 # load first argument
11714: jsb gtnvr # point to vrblk
11715: .long sloc1 # jump if not variable name
11716: movl 4*vrfnc(r9),r9 # else load function pointer
11717: cmpl (r9),$b$pfc # jump if not program defined
11718: bnequ sloc1
11719: #
11720: # HERE IF WE HAVE A PROGRAM DEFINED FUNCTION NAME
11721: #
11722: tstl r7 # fail if second arg is zero
11723: bnequ 0f
11724: jmp exfal
11725: 0:
11726: cmpl r7,4*pfnlo(r9) # or too large
11727: blequ 0f
11728: jmp exfal
11729: 0:
11730: addl2 4*fargs(r9),r7 # else adjust offset to include args
11731: moval 0[r7],r7 # convert to bytes
11732: addl2 r7,r9 # point to local pointer
11733: movl 4*pfagb(r9),r9 # load vrblk pointer
11734: jmp exvnm # exit building nmblk
11735: #
11736: # HERE IF FIRST ARGUMENT IS NO GOOD
11737: #
11738: sloc1: jmp er_135 # local first arg is not a program function name
11739: #page
11740: #
11741: # LOAD
11742: #
11743: s$lod: # entry point
11744: jsb gtstg # load library name
11745: .long er_136 # load second argument is not string
11746: movl r9,r10 # save library name
11747: jsb xscni # prepare to scan first argument
11748: .long er_137 # load first argument is not string
11749: .long er_138 # load first argument is null
11750: movl r10,-(sp) # stack library name
11751: movl $ch$pp,r8 # set delimiter one = left paren
11752: movl r8,r10 # set delimiter two = left paren
11753: jsb xscan # scan function name
11754: movl r9,-(sp) # save ptr to function name
11755: tstl r6 # jump if left paren found
11756: bnequ slod1
11757: jmp er_139 # load first argument is missing a left paren
11758: #
11759: # HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME
11760: #
11761: slod1: jsb gtnvr # locate vrblk
11762: .long er_140 # load first argument has null function name
11763: movl r9,lodfn # save vrblk pointer
11764: clrl lodna # zero count of arguments
11765: #
11766: # LOOP TO SCAN ARGUMENT DATATYPE NAMES
11767: #
11768: slod2: movl $ch$rp,r8 # delimiter one is right paren
11769: movl $ch$cm,r10 # delimiter two is comma
11770: jsb xscan # scan next argument name
11771: incl lodna # bump argument count
11772: tstl r6 # jump if ok delimiter was found
11773: bnequ slod3
11774: jmp er_141 # load first argument is missing a right paren
11775: #page
11776: #
11777: # LOAD (CONTINUED)
11778: #
11779: # COME HERE TO ANALYZE THE DATATYPE POINTER IN (XR). THIS
11780: # CODE IS USED BOTH FOR ARGUMENTS (WA=1,2) AND FOR THE
11781: # RESULT DATATYPE (WITH WA SET TO ZERO).
11782: #
11783: slod3: movl r9,-(sp) # stack datatype name pointer
11784: movl $num01,r7 # set string code in case
11785: movl $scstr,r10 # point to /string/
11786: jsb ident # check for match
11787: .long slod4 # jump if match
11788: movl (sp),r9 # else reload name
11789: addl2 r7,r7 # set code for integer (2)
11790: movl $scint,r10 # point to /integer/
11791: jsb ident # check for match
11792: .long slod4 # jump if match
11793: movl (sp),r9 # else reload string pointer
11794: incl r7 # set code for real (3)
11795: movl $screa,r10 # point to /real/
11796: jsb ident # check for match
11797: .long slod4 # jump if match
11798: clrl r7 # else get code for no convert
11799: #
11800: # MERGE HERE WITH PROPER DATATYPE CODE IN WB
11801: #
11802: slod4: movl r7,(sp) # store code on stack
11803: cmpl r6,$num02 # loop back if arg stopped by comma
11804: beqlu slod2
11805: tstl r6 # jump if that was the result type
11806: beqlu slod5
11807: #
11808: # HERE WE SCAN OUT THE RESULT TYPE (ARG STOPPED BY ) )
11809: #
11810: movl mxlen,r8 # set dummy (impossible) delimiter 1
11811: movl r8,r10 # and delimiter two
11812: jsb xscan # scan result name
11813: clrl r6 # set code for processing result
11814: jmp slod3 # jump back to process result name
11815: #page
11816: #
11817: # LOAD (CONTINUED)
11818: #
11819: # HERE AFTER PROCESSING ALL ARGS AND RESULT
11820: #
11821: slod5: movl lodna,r6 # get number of arguments
11822: movl r6,r8 # copy for later
11823: moval 0[r6],r6 # convert length to bytes
11824: addl2 $4*efsi$,r6 # add space for standard fields
11825: jsb alloc # allocate efblk
11826: movl $b$efc,(r9) # set type word
11827: movl r8,4*fargs(r9) # set number of arguments
11828: clrl 4*efuse(r9) # set use count (dffnc will set to 1)
11829: clrl 4*efcod(r9) # zero code pointer for now
11830: movl (sp)+,4*efrsl(r9)# store result type code
11831: movl lodfn,4*efvar(r9)# store function vrblk pointer
11832: movl r6,4*eflen(r9) # store efblk length
11833: movl r9,r7 # save efblk pointer
11834: addl2 r6,r9 # point past end of efblk
11835: # set number of arguments for loop
11836: #
11837: # LOOP TO SET ARGUMENT TYPE CODES FROM STACK
11838: #
11839: slod6: movl (sp)+,-(r9) # store one type code from stack
11840: sobgtr r8,slod6 # loop till all stored
11841: #
11842: # NOW LOAD THE EXTERNAL FUNCTION AND PERFORM DEFINITION
11843: #
11844: movl (sp)+,r9 # load function string name
11845: movl (sp),r10 # load library name
11846: movl r7,(sp) # store efblk pointer
11847: jsb sysld # call function to load external func
11848: .long er_142 # load function does not exist
11849: .long er_143 # load function caused input error during load
11850: movl (sp)+,r10 # recall efblk pointer
11851: movl r9,4*efcod(r10) # store code pointer
11852: movl lodfn,r9 # point to vrblk for function
11853: jsb dffnc # perform function definition
11854: jmp exnul # return null result
11855: #page
11856: #
11857: # LPAD
11858: #
11859: s$lpd: # entry point
11860: jsb gtstg # get pad character
11861: .long er_144 # lpad third argument not a string
11862: movab cfp$f(r9),r9 # point to character (null is blank)
11863: movzbl (r9),r7 # load pad character
11864: jsb gtsmi # get pad length
11865: .long er_145 # lpad second argument is not integer
11866: .long slpd3 # skip if negative or large
11867: #
11868: # MERGE TO CHECK FIRST ARG
11869: #
11870: slpd1: jsb gtstg # get first argument (string to pad)
11871: .long er_146 # lpad first argument is not string
11872: cmpl r6,r8 # return 1st arg if too long to pad
11873: blssu 0f
11874: jmp exixr
11875: 0:
11876: movl r9,r10 # else move ptr to string to pad
11877: #
11878: # NOW WE ARE READY FOR THE PAD
11879: #
11880: # (XL) POINTER TO STRING TO PAD
11881: # (WB) PAD CHARACTER
11882: # (WC) LENGTH TO PAD STRING TO
11883: #
11884: movl r8,r6 # copy length
11885: jsb alocs # allocate scblk for new string
11886: movl r9,-(sp) # save as result
11887: movl 4*sclen(r10),r6 # load length of argument
11888: subl2 r6,r8 # calculate number of pad characters
11889: movab cfp$f(r9),r9 # point to chars in result string
11890: # set counter for pad loop
11891: #
11892: # LOOP TO PERFORM PAD
11893: #
11894: slpd2: movb r7,(r9)+ # store pad character, bump ptr
11895: sobgtr r8,slpd2 # loop till all pad chars stored
11896: #csc r9 # complete store characters
11897: #
11898: # NOW COPY STRING
11899: #
11900: tstl r6 # exit if null string
11901: bnequ 0f
11902: jmp exits
11903: 0:
11904: movab cfp$f(r10),r10 # else point to chars in argument
11905: jsb sbmvc # move characters to result string
11906: jmp exits # jump for next code word
11907: #
11908: # HERE IF 2ND ARG IS NEGATIVE OR LARGE
11909: #
11910: slpd3: clrl r8 # zero pad count
11911: jmp slpd1 # merge
11912: #page
11913: #
11914: # LT
11915: #
11916: s$ltf: # entry point
11917: jsb acomp # call arithmetic comparison routine
11918: .long er_147 # lt first argument is not numeric
11919: .long er_148 # lt second argument is not numeric
11920: .long exnul # return null if lt
11921: .long exfal # fail if eq
11922: .long exfal # fail if gt
11923: #page
11924: #
11925: # NE
11926: #
11927: s$nef: # entry point
11928: jsb acomp # call arithmetic comparison routine
11929: .long er_149 # ne first argument is not numeric
11930: .long er_150 # ne second argument is not numeric
11931: .long exnul # return null if lt
11932: .long exfal # fail if eq
11933: .long exnul # return null if gt
11934: #page
11935: #
11936: # NOTANY
11937: #
11938: s$nay: # entry point
11939: movl $p$nas,r7 # set pcode for single char arg
11940: movl $p$nay,r10 # pcode for multi-char arg
11941: movl $p$nad,r8 # set pcode for expr arg
11942: jsb patst # call common routine to build node
11943: .long er_151 # notany argument is not string or expression
11944: jmp exixr # jump for next code word
11945: #page
11946: #
11947: # OPSYN
11948: #
11949: s$ops: # entry point
11950: jsb gtsmi # load third argument
11951: .long er_152 # opsyn third argument is not integer
11952: .long er_153 # opsyn third argument is negative or too large
11953: movl r8,r7 # if ok, save third argumnet
11954: movl (sp)+,r9 # load second argument
11955: jsb gtnvr # locate variable block
11956: .long er_154 # opsyn second arg is not natural variable name
11957: movl 4*vrfnc(r9),r10 # if ok, load function block pointer
11958: tstl r7 # jump if operator opsyn case
11959: bnequ sops2
11960: #
11961: # HERE FOR FUNCTION OPSYN (THIRD ARG ZERO)
11962: #
11963: movl (sp)+,r9 # load first argument
11964: jsb gtnvr # get vrblk pointer
11965: .long er_155 # opsyn first arg is not natural variable name
11966: #
11967: # MERGE HERE TO PERFORM FUNCTION DEFINITION
11968: #
11969: sops1: jsb dffnc # call function definer
11970: jmp exnul # exit with null result
11971: #
11972: # HERE FOR OPERATOR OPSYN (THIRD ARG NON-ZERO)
11973: #
11974: sops2: jsb gtstg # get operator name
11975: .long sops5 # jump if not string
11976: cmpl r6,$num01 # error if not one char long
11977: bnequ sops5
11978: movab cfp$f(r9),r9 # else point to character
11979: movzbl (r9),r8 # load character name
11980: #page
11981: #
11982: # OPSYN (CONTINUED)
11983: #
11984: # NOW SET TO SEARCH FOR MATCHING UNARY OR BINARY OPERATOR
11985: # NAME AS APPROPRIATE. NOTE THAT THERE ARE =OPBUN UNDEFINED
11986: # BINARY OPERATORS AND =OPUUN UNDEFINED UNARY OPERATORS.
11987: #
11988: movl $r$uub,r6 # point to unop pointers in case
11989: movl $opnsu,r9 # point to names of unary operators
11990: addl2 $opbun,r7 # add no. of undefined binary ops
11991: cmpl r7,$opuun # jump if unop (third arg was 1)
11992: beqlu sops3
11993: movl $r$uba,r6 # else point to binary operator ptrs
11994: movl $opsnb,r9 # point to names of binary operators
11995: movl $opbun,r7 # set number of undefined binops
11996: #
11997: # MERGE HERE TO CHECK LIST (WB = NUMBER TO CHECK)
11998: #
11999: sops3: # set counter to control loop
12000: #
12001: # LOOP TO SEARCH FOR NAME MATCH
12002: #
12003: sops4: cmpl r8,(r9) # jump if names match
12004: beqlu sops6
12005: addl2 $4,r6 # else push pointer to function ptr
12006: addl2 $4,r9 # bump pointer
12007: sobgtr r7,sops4 # loop back till all checked
12008: #
12009: # HERE IF BAD OPERATOR NAME
12010: #
12011: sops5: jmp er_156 # opsyn first arg is not correct operator name
12012: #
12013: # COME HERE ON FINDING A MATCH IN THE OPERATOR NAME TABLE
12014: #
12015: sops6: movl r6,r9 # copy pointer to function block ptr
12016: subl2 $4*vrfnc,r9 # make it look like dummy vrblk
12017: jmp sops1 # merge back to define operator
12018: #page
12019: #
12020: # OUTPUT
12021: #
12022: s$oup: # entry point
12023: movl $num03,r7 # output flag
12024: jsb ioput # call input/output assoc. routine
12025: .long er_157 # output third argument is not a string
12026: .long er_158 # inappropriate second argument for output
12027: .long er_159 # inappropriate first argument for output
12028: .long er_160 # inappropriate file specification for output
12029: .long exfal # fail if file does not exist
12030: .long er_161 # output file cannot be written to
12031: jmp exnul # return null string
12032: #page
12033: #
12034: # POS
12035: #
12036: s$pos: # entry point
12037: movl $p$pos,r7 # set pcode for integer arg case
12038: movl $p$psd,r6 # set pcode for expression arg case
12039: jsb patin # call common routine to build node
12040: .long er_162 # pos argument is not integer or expression
12041: .long er_163 # pos argument is negative or too large
12042: jmp exixr # return pattern node
12043: #page
12044: #
12045: # PROTOTYPE
12046: #
12047: s$pro: # entry point
12048: movl (sp)+,r9 # load argument
12049: movl 4*tblen(r9),r7 # length if table, vector (=vclen)
12050: ashl $-2,r7,r7 # convert to words
12051: movl (r9),r6 # load type word of argument block
12052: cmpl r6,$b$art # jump if array
12053: beqlu spro4
12054: cmpl r6,$b$tbt # jump if table
12055: beqlu spro1
12056: cmpl r6,$b$vct # jump if vector
12057: beqlu spro3
12058: cmpl r6,$b$bct # jump if buffer
12059: beqlu spr05
12060: jmp er_164 # prototype argument is not valid object
12061: #
12062: # HERE FOR TABLE
12063: #
12064: spro1: subl2 $tbsi$,r7 # subtract standard fields
12065: #
12066: # MERGE FOR VECTOR
12067: #
12068: spro2: movl r7,r5 # convert to integer
12069: jmp exint # exit with integer result
12070: #
12071: # HERE FOR VECTOR
12072: #
12073: spro3: subl2 $vcsi$,r7 # subtract standard fields
12074: jmp spro2 # merge
12075: #
12076: # HERE FOR ARRAY
12077: #
12078: spro4: addl2 4*arofs(r9),r9 # point to prototype field
12079: movl (r9),r9 # load prototype
12080: jmp exixr # return prototype as result
12081: #
12082: # HERE FOR BUFFER
12083: #
12084: spr05: movl 4*bcbuf(r9),r9 # point to bfblk
12085: movl 4*bfalc(r9),r5 # load allocated length
12086: jmp exint # exit with integer allocation
12087: #page
12088: #
12089: # REMDR
12090: #
12091: s$rmd: # entry point
12092: clrl r7 # set positive flag
12093: movl (sp),r9 # load second argument
12094: jsb gtint # convert to integer
12095: .long er_165 # remdr second argument is not integer
12096: jsb arith # convert args
12097: .long srm01 # first arg not integer
12098: .long invalid$ # second arg checked above
12099: .long srm01 # first arg real
12100: movl 4*icval(r9),r5 # load left argument value
12101: ashq $-32,r4,r4 # get remainder
12102: ediv 4*icval(r10),r4,r11,r5
12103: bvs 0f
12104: jmp exint
12105: 0:
12106: jmp er_167 # remdr caused integer overflow
12107: #
12108: # FAIL FIRST ARGUMENT
12109: #
12110: srm01: jmp er_166 # remdr first argument is not integer
12111: #page
12112: #
12113: # REPLACE
12114: #
12115: # THE ACTUAL REPLACE OPERATION USES AN SCBLK WHOSE CFP$A
12116: # CHARS CONTAIN THE TRANSLATED VERSIONS OF ALL THE CHARS.
12117: # THE TABLE POINTER IS REMEMBERED FROM CALL TO CALL AND
12118: # THE TABLE IS ONLY BUILT WHEN THE ARGUMENTS CHANGE.
12119: #
12120: s$rpl: # entry point
12121: jsb gtstg # load third argument as string
12122: .long er_168 # replace third argument is not string
12123: movl r9,r10 # save third arg ptr
12124: jsb gtstg # get second argument
12125: .long er_169 # replace second argument is not string
12126: #
12127: # CHECK TO SEE IF THIS IS THE SAME TABLE AS LAST TIME
12128: #
12129: cmpl r9,r$ra2 # jump if 2nd argument different
12130: bnequ srpl1
12131: cmpl r10,r$ra3 # jump if args same as last time
12132: bnequ 0f
12133: jmp srpl4
12134: 0:
12135: #
12136: # HERE WE BUILD A NEW REPLACE TABLE (NOTE WA = 2ND ARG LEN)
12137: #
12138: srpl1: movl 4*sclen(r10),r7 # load 3rd argument length
12139: cmpl r6,r7 # jump if arguments not same length
12140: beqlu 0f
12141: jmp srpl5
12142: 0:
12143: tstl r7 # jump if null 2nd argument
12144: bnequ 0f
12145: jmp srpl5
12146: 0:
12147: movl r10,r$ra3 # save third arg for next time in
12148: movl r9,r$ra2 # save second arg for next time in
12149: movl kvalp,r10 # point to alphabet string
12150: movl 4*sclen(r10),r6 # load alphabet scblk length
12151: movl r$rpt,r9 # point to current table (if any)
12152: tstl r9 # jump if we already have a table
12153: bnequ srpl2
12154: #
12155: # HERE WE ALLOCATE A NEW TABLE
12156: #
12157: jsb alocs # allocate new table
12158: movl r8,r6 # keep scblk length
12159: movl r9,r$rpt # save table pointer for next time
12160: #
12161: # MERGE HERE WITH POINTER TO NEW TABLE BLOCK IN (XR)
12162: #
12163: srpl2: movab 3+(4*scsi$)(r6),r6 # compute length of scblk
12164: bicl2 $3,r6
12165: jsb sbmvw # copy to get initial table values
12166: #page
12167: #
12168: # REPLACE (CONTINUED)
12169: #
12170: # NOW WE MUST PLUG SELECTED ENTRIES AS REQUIRED. NOTE THAT
12171: # WE ARE SHORT OF INDEX REGISTERS FOR THE FOLLOWING LOOP.
12172: # HENCE THE NEED TO REPEATEDLY RE-INITIALISE CHAR PTR XL
12173: #
12174: movl r$ra2,r10 # point to second argument
12175: # number of chars to plug
12176: clrl r8 # zero char offset
12177: movl r$ra3,r9 # point to 3rd arg
12178: movab cfp$f(r9),r9 # get char ptr for 3rd arg
12179: #
12180: # LOOP TO PLUG CHARS
12181: #
12182: srpl3: movl r$ra2,r10 # point to 2nd arg
12183: movab cfp$f(r10)[r8],r10 # point to next char
12184: incl r8 # increment offset
12185: movzbl (r10),r6 # get next char
12186: movl r$rpt,r10 # point to translate table
12187: movab cfp$f(r10)[r6],r10 # convert char to offset into table
12188: movzbl (r9)+,r6 # get translated char
12189: movb r6,(r10) # store in table
12190: #csc r10 # complete store characters
12191: sobgtr r7,srpl3 # loop till done
12192: #page
12193: #
12194: # REPLACE (CONTINUED)
12195: #
12196: # HERE TO PERFORM TRANSLATE
12197: #
12198: srpl4: jsb gtstg # get first argument
12199: .long er_170 # replace first argument is not string
12200: tstl r6 # return null if null argument
12201: bnequ 0f
12202: jmp exnul
12203: 0:
12204: movl r9,r10 # copy pointer
12205: movl r6,r8 # save length
12206: movab 3+(4*schar)(r6),r6 # get scblk length
12207: bicl2 $3,r6
12208: jsb alloc # allocate space for copy
12209: movl r9,r7 # save address of copy
12210: jsb sbmvw # move scblk contents to copy
12211: movl r$rpt,r9 # point to replace table
12212: movab cfp$f(r9),r9 # point to chars of table
12213: movl r7,r10 # point to string to translate
12214: movab cfp$f(r10),r10 # point to chars of string
12215: movl r8,r6 # set number of chars to translate
12216: jsb sbtrc # perform translation
12217: movl r7,-(sp) # stack new string as result
12218: jmp exits # return with result on stack
12219: #
12220: # ERROR POINT
12221: #
12222: srpl5: jmp er_171 # null or unequally long 2nd, 3rd args to replace
12223: #page
12224: #
12225: # REWIND
12226: #
12227: s$rew: # entry point
12228: jsb iofcb # call fcblk routine
12229: .long er_172 # rewind argument is not a suitable name
12230: .long er_173 # rewind argument is null
12231: jsb sysrw # call system rewind function
12232: .long er_174 # rewind file does not exist
12233: .long er_175 # rewind file does not permit rewind
12234: .long er_176 # rewind caused non-recoverable error
12235: jmp exnul # exit with null result if no error
12236: #page
12237: #
12238: # REVERSE
12239: #
12240: s$rvs: # entry point
12241: jsb gtstg # load string argument
12242: .long er_177 # reverse argument is not string
12243: tstl r6 # return argument if null
12244: bnequ 0f
12245: jmp exixr
12246: 0:
12247: movl r9,r10 # else save pointer to string arg
12248: jsb alocs # allocate space for new scblk
12249: movl r9,-(sp) # store scblk ptr on stack as result
12250: movab cfp$f(r9),r9 # prepare to store in new scblk
12251: movab cfp$f(r10)[r8],r10 # point past last char in argument
12252: # set loop counter
12253: #
12254: # LOOP TO MOVE CHARS IN REVERSE ORDER
12255: #
12256: srvs1: movzbl -(r10),r7 # load next char from argument
12257: movb r7,(r9)+ # store in result
12258: sobgtr r8,srvs1 # loop till all moved
12259: #csc r9 # complete store characters
12260: jmp exits # and then jump for next code word
12261: #page
12262: #
12263: # RPAD
12264: #
12265: s$rpd: # entry point
12266: jsb gtstg # get pad character
12267: .long er_178 # rpad third argument is not string
12268: movab cfp$f(r9),r9 # point to character (null is blank)
12269: movzbl (r9),r7 # load pad character
12270: jsb gtsmi # get pad length
12271: .long er_179 # rpad second argument is not integer
12272: .long srpd3 # skip if negative or large
12273: #
12274: # MERGE TO CHECK FIRST ARG.
12275: #
12276: srpd1: jsb gtstg # get first argument (string to pad)
12277: .long er_180 # rpad first argument is not string
12278: cmpl r6,r8 # return 1st arg if too long to pad
12279: blssu 0f
12280: jmp exixr
12281: 0:
12282: movl r9,r10 # else move ptr to string to pad
12283: #
12284: # NOW WE ARE READY FOR THE PAD
12285: #
12286: # (XL) POINTER TO STRING TO PAD
12287: # (WB) PAD CHARACTER
12288: # (WC) LENGTH TO PAD STRING TO
12289: #
12290: movl r8,r6 # copy length
12291: jsb alocs # allocate scblk for new string
12292: movl r9,-(sp) # save as result
12293: movl 4*sclen(r10),r6 # load length of argument
12294: subl2 r6,r8 # calculate number of pad characters
12295: movab cfp$f(r9),r9 # point to chars in result string
12296: # set counter for pad loop
12297: #
12298: # COPY ARGUMENT STRING
12299: #
12300: tstl r6 # jump if argument is null
12301: beqlu srpd2
12302: movab cfp$f(r10),r10 # else point to argument chars
12303: jsb sbmvc # move characters to result string
12304: #
12305: # LOOP TO SUPPLY PAD CHARACTERS
12306: #
12307: srpd2: movb r7,(r9)+ # store pad character, bump ptr
12308: sobgtr r8,srpd2 # loop till all pad chars stored
12309: #csc r9 # complete character storing
12310: jmp exits # and exit for next word
12311: #
12312: # HERE IF 2ND ARG IS NEGATIVE OR LARGE
12313: #
12314: srpd3: clrl r8 # zero pad count
12315: jmp srpd1 # merge
12316: #page
12317: #
12318: # RTAB
12319: #
12320: s$rtb: # entry point
12321: movl $p$rtb,r7 # set pcode for integer arg case
12322: movl $p$rtd,r6 # set pcode for expression arg case
12323: jsb patin # call common routine to build node
12324: .long er_181 # rtab argument is not integer or expression
12325: .long er_182 # rtab argument is negative or too large
12326: jmp exixr # return pattern node
12327: #page
12328: #
12329: # SET
12330: #
12331: s$set: # entry point
12332: movl (sp)+,r$io2 # save third arg
12333: movl (sp)+,r$io1 # save second arg
12334: jsb iofcb # call fcblk routine
12335: .long er_291 # set first argument is not a suitable name
12336: .long er_292 # set first argument is null
12337: movl r$io1,r7 # load second arg
12338: movl r$io2,r8 # load third arg
12339: jsb sysst # call system set routine
12340: .long er_293 # inappropriate second argument to set
12341: .long er_294 # inappropriate third argument to set
12342: .long er_295 # set file does not exist
12343: .long er_296 # set file does not permit setting file pointer
12344: .long er_297 # set caused non-recoverable i/o error
12345: jmp exnul # otherwisew return null
12346: #page
12347: #
12348: # TAB
12349: #
12350: s$tab: # entry point
12351: movl $p$tab,r7 # set pcode for integer arg case
12352: movl $p$tbd,r6 # set pcode for expression arg case
12353: jsb patin # call common routine to build node
12354: .long er_183 # tab argument is not integer or expression
12355: .long er_184 # tab argument is negative or too large
12356: jmp exixr # return pattern node
12357: #page
12358: #
12359: # RPOS
12360: #
12361: s$rps: # entry point
12362: movl $p$rps,r7 # set pcode for integer arg case
12363: movl $p$rpd,r6 # set pcode for expression arg case
12364: jsb patin # call common routine to build node
12365: .long er_185 # rpos argument is not integer or expression
12366: .long er_186 # rpos argument is negative or too large
12367: jmp exixr # return pattern node
12368: #page
12369: #
12370: # RSORT
12371: #
12372: s$rsr: # entry point
12373: movl sp,r6 # mark as rsort
12374: jsb sorta # call sort routine
12375: jmp exsid # return, setting idval
12376: #page
12377: #
12378: # SETEXIT
12379: #
12380: s$stx: # entry point
12381: movl (sp)+,r9 # load argument
12382: movl stxvr,r6 # load old vrblk pointer
12383: clrl r10 # load zero in case null arg
12384: cmpl r9,$nulls # jump if null argument (reset call)
12385: beqlu sstx1
12386: jsb gtnvr # else get specified vrblk
12387: .long sstx2 # jump if not natural variable
12388: movl 4*vrlbl(r9),r10 # else load label
12389: cmpl r10,$stndl # jump if label is not defined
12390: beqlu sstx2
12391: cmpl (r10),$b$trt # jump if not trapped
12392: bnequ sstx1
12393: movl 4*trlbl(r10),r10# else load ptr to real label code
12394: #
12395: # HERE TO SET/RESET SETEXIT TRAP
12396: #
12397: sstx1: movl r9,stxvr # store new vrblk pointer (or null)
12398: movl r10,r$sxc # store new code ptr (or zero)
12399: cmpl r6,$nulls # return null if null result
12400: bnequ 0f
12401: jmp exnul
12402: 0:
12403: movl r6,r9 # else copy vrblk pointer
12404: jmp exvnm # and return building nmblk
12405: #
12406: # HERE IF BAD ARGUMENT
12407: #
12408: sstx2: jmp er_187 # setexit argument is not label name or null
12409: #page
12410: #
12411: # SORT
12412: #
12413: s$srt: # entry point
12414: clrl r6 # mark as sort
12415: jsb sorta # call sort routine
12416: jmp exsid # return, setting idval
12417: #page
12418: #
12419: # SPAN
12420: #
12421: s$spn: # entry point
12422: movl $p$sps,r7 # set pcode for single char arg
12423: movl $p$spn,r10 # set pcode for multi-char arg
12424: movl $p$spd,r8 # set pcode for expression arg
12425: jsb patst # call common routine to build node
12426: .long er_188 # span argument is not string or expression
12427: jmp exixr # jump for next code word
12428: #page
12429: #
12430: # SIZE
12431: #
12432: s$si$: # entry point
12433: movl (sp),r9 # load argument
12434: cmpl (r9),$b$bct # branch if not buffer
12435: bnequ ssi$1
12436: addl2 $4,sp # else pop argument
12437: movl 4*bclen(r9),r5 # load defined length
12438: jmp exint # exit with integer
12439: #
12440: # HERE IF NOT BUFFER
12441: #
12442: ssi$1: jsb gtstg # load string argument
12443: .long er_189 # size argument is not string
12444: movl r6,r5 # load length as integer
12445: jmp exint # exit with integer result
12446: #page
12447: #
12448: # STOPTR
12449: #
12450: s$stt: # entry point
12451: clrl r10 # indicate stoptr case
12452: jsb trace # call trace procedure
12453: .long er_190 # stoptr first argument is not appropriate name
12454: .long er_191 # stoptr second argument is not trace type
12455: jmp exnul # return null
12456: #page
12457: #
12458: # SUBSTR
12459: #
12460: s$sub: # entry point
12461: jsb gtsmi # load third argument
12462: .long er_192 # substr third argument is not integer
12463: .long exfal # jump if negative or too large
12464: movl r9,sbssv # save third argument
12465: jsb gtsmi # load second argument
12466: .long er_193 # substr second argument is not integer
12467: .long exfal # jump if out of range
12468: movl r9,r7 # save second argument
12469: tstl r7 # jump if second argument zero
12470: bnequ 0f
12471: jmp exfal
12472: 0:
12473: decl r7 # else decrement for ones origin
12474: movl (sp),r10 # get first arg ptr
12475: cmpl (r10),$b$bct # branch if not buffer
12476: bnequ ssuba
12477: movl 4*bcbuf(r10),r9 # get bfblk ptr
12478: movl 4*bclen(r10),r6 # get length
12479: jmp ssubb # merge
12480: #
12481: # HERE IF NOT BUFFER TO GET STRING
12482: #
12483: ssuba: jsb gtstg # load first argument
12484: .long er_194 # substr first argument is not string
12485: #
12486: # MERGE WITH BFBLK OR SCBLK PTR IN XR. WA HAS LENGTH
12487: #
12488: ssubb: movl sbssv,r8 # reload third argument
12489: tstl r8 # skip if third arg given
12490: bnequ ssub1
12491: movl r6,r8 # else get string length
12492: cmpl r7,r8 # fail if improper
12493: blequ 0f
12494: jmp exfal
12495: 0:
12496: subl2 r7,r8 # reduce by offset to start
12497: #
12498: # MERGE
12499: #
12500: ssub1: movl r6,r10 # save string length
12501: movl r8,r6 # set length of substring
12502: addl2 r7,r8 # add 2nd arg to 3rd arg
12503: cmpl r8,r10 # jump if improper substring
12504: blequ 0f
12505: jmp exfal
12506: 0:
12507: movl r9,r10 # copy pointer to first arg
12508: jsb sbstr # build substring
12509: jmp exixr # and jump for next code word
12510: #page
12511: #
12512: # TABLE
12513: #
12514: s$tbl: # entry point
12515: movl (sp)+,r10 # get initial lookup value
12516: addl2 $4,sp # pop second argument
12517: jsb gtsmi # load argument
12518: .long er_195 # table argument is not integer
12519: .long er_196 # table argument is out of range
12520: tstl r8 # jump if non-zero
12521: bnequ stbl1
12522: movl $tbnbk,r8 # else supply default value
12523: #
12524: # MERGE HERE WITH NUMBER OF HEADERS IN WA
12525: #
12526: stbl1: movl r8,r6 # copy number of headers
12527: addl2 $tbsi$,r6 # adjust for standard fields
12528: moval 0[r6],r6 # convert length to bytes
12529: jsb alloc # allocate space for tbblk
12530: movl r9,r7 # copy pointer to tbblk
12531: movl $b$tbt,(r9)+ # store type word
12532: clrl (r9)+ # zero id for the moment
12533: movl r6,(r9)+ # store length (tblen)
12534: movl r10,(r9)+ # store initial lookup value
12535: # set loop counter (num headers)
12536: #
12537: # LOOP TO INITIALIZE ALL BUCKET POINTERS
12538: #
12539: stbl2: movl r7,(r9)+ # store tbblk ptr in bucket header
12540: sobgtr r8,stbl2 # loop till all stored
12541: movl r7,r9 # recall pointer to tbblk
12542: jmp exsid # exit setting idval
12543: #page
12544: #
12545: # TIME
12546: #
12547: s$tim: # entry point
12548: jsb systm # get timer value
12549: subl2 timsx,r5 # subtract starting time
12550: jmp exint # exit with integer value
12551: #page
12552: #
12553: # TRACE
12554: #
12555: s$tra: # entry point
12556: cmpl 4*3(sp),$nulls # jump if first argument is null
12557: beqlu str03
12558: movl (sp)+,r9 # load fourth argument
12559: clrl r10 # tentatively set zero pointer
12560: cmpl r9,$nulls # jump if 4th argument is null
12561: beqlu str02
12562: jsb gtnvr # else point to vrblk
12563: .long str01 # jump if not variable name
12564: movl 4*vrfnc(r9),r10 # else load function pointer
12565: cmpl r10,$stndf # jump if function is defined
12566: bnequ str02
12567: #
12568: # HERE FOR BAD FOURTH ARGUMENT
12569: #
12570: str01: jmp er_197 # trace fourth arg is not function name or null
12571: #
12572: # HERE WITH FUNCTION POINTER IN XL
12573: #
12574: str02: movl (sp)+,r9 # load third argument (tag)
12575: clrl r7 # set zero as trtyp value for now
12576: jsb trbld # build trblk for trace call
12577: movl r9,r10 # move trblk pointer for trace
12578: jsb trace # call trace procedure
12579: .long er_198 # trace first argument is not appropriate name
12580: .long er_199 # trace second argument is not trace type
12581: jmp exnul # return null
12582: #
12583: # HERE TO CALL SYSTEM TRACE TOGGLE ROUTINE
12584: #
12585: str03: jsb systt # call it
12586: addl2 $4*num04,sp # pop trace arguments
12587: jmp exnul # return
12588: #page
12589: #
12590: # TRIM
12591: #
12592: s$trm: # entry point
12593: jsb gtstg # load argument as string
12594: .long er_200 # trim argument is not string
12595: tstl r6 # return null if argument is null
12596: bnequ 0f
12597: jmp exnul
12598: 0:
12599: movl r9,r10 # copy string pointer
12600: movab 3+(4*schar)(r6),r6 # get block length
12601: bicl2 $3,r6
12602: jsb alloc # allocate copy same size
12603: movl r9,r7 # save pointer to copy
12604: jsb sbmvw # copy old string block to new
12605: movl r7,r9 # restore ptr to new block
12606: jsb trimr # trim blanks (wb is non-zero)
12607: jmp exixr # exit with result in xr
12608: #page
12609: #
12610: # UNLOAD
12611: #
12612: s$unl: # entry point
12613: movl (sp)+,r9 # load argument
12614: jsb gtnvr # point to vrblk
12615: .long er_201 # unload argument is not natural variable name
12616: movl $stndf,r10 # get ptr to undefined function
12617: jsb dffnc # undefine named function
12618: jmp exnul # return null as result
12619: #title s p i t b o l -- utility procedures
12620: #
12621: # THE FOLLOWING SECTION CONTAINS PROCEDURES WHICH ARE
12622: # USED FOR VARIOUS PURPOSES THROUGHOUT THE SYSTEM.
12623: #
12624: # EACH PROCEDURE IS PRECEDED BY A DESCRIPTION OF THE
12625: # CALLING SEQUENCE. USUALLY THE ARGUMENTS ARE IN REGISTERS
12626: # BUT ARGUMENTS CAN ALSO OCCUR ON THE STACK AND AS
12627: # PARAMETERS ASSEMBLED AFTER THE JSR INSTRUCTION.
12628: #
12629: # THE FOLLOWING CONSIDERATIONS APPLY TO THESE DESCRIPTIONS.
12630: #
12631: # 1) THE STACK POINTER (XS) IS NOT CHANGED UNLESS THE
12632: # CHANGE IS EXPLICITLY DOCUMENTED IN THE CALL.
12633: #
12634: # 2) REGISTERS WHOSE ENTRY VALUES ARE NOT MENTIONED
12635: # MAY CONTAIN ANY VALUE EXCEPT THAT XL,XR MAY ONLY
12636: # CONTAIN PROPER (COLLECTABLE) POINTER VALUES.
12637: # THIS CONDITION ON XR MEANS THAT THE CALLED ROUTINE
12638: # MAY IF IT CHOOSES PRESERVE XR BY STACKING.
12639: #
12640: # 3) REGISTERS NOT MENTIONED ON EXIT CONTAIN THE SAME
12641: # VALUES AS THEY DID ON ENTRY EXCEPT THAT VALUES IN
12642: # XR,XL MAY HAVE BEEN RELOCATED BY THE COLLECTOR.
12643: #
12644: # 4) REGISTERS WHICH ARE DESTROYED ON EXIT MAY CONTAIN
12645: # ANY VALUE EXCEPT THAT VALUES IN XL,XR ARE PROPER
12646: # (COLLECTABLE) POINTERS.
12647: #
12648: # 5) THE CODE POINTER REGISTER POINTS TO THE CURRENT
12649: # CODE LOCATION ON ENTRY AND IS UNCHANGED ON EXIT.
12650: #
12651: # IN THE ABOVE DESCRIPTION, A COLLECTABLE POINTER IS ONE
12652: # WHICH EITHER POINTS OUTSIDE THE DYNAMIC REGION OR
12653: # POINTS TO THE START OF A BLOCK IN THE DYNAMIC REGION.
12654: #
12655: # IN THOSE CASES WHERE THE CALLING SEQUENCE CONTAINS
12656: # PARAMETERS WHICH ARE USED AS ALTERNATE RETURN POINTS,
12657: # THESE PARAMETERS MAY BE REPLACED BY ERROR CODES
12658: # ASSEMBLED WITH THE ERR INSTRUCTION. THIS WILL RESULT
12659: # IN THE POSTING OF THE ERROR IF THE RETURN IS TAKEN.
12660: #
12661: # THE PROCEDURES ALL HAVE NAMES CONSISTING OF FIVE LETTERS
12662: # AND ARE IN ALPHABETICAL ORDER BY THEIR NAMES.
12663: #page
12664: #
12665: # ACESS - ACCESS VARIABLE VALUE WITH TRACE/INPUT CHECKS
12666: #
12667: # ACESS LOADS THE VALUE OF A VARIABLE. TRACE AND INPUT
12668: # ASSOCIATIONS ARE TESTED FOR AND EXECUTED AS REQUIRED.
12669: # ACESS ALSO HANDLES THE SPECIAL CASES OF PSEUDO-VARIABLES.
12670: #
12671: # (XL) VARIABLE NAME BASE
12672: # (WA) VARIABLE NAME OFFSET
12673: # JSR ACESS CALL TO ACCESS VALUE
12674: # PPM LOC TRANSFER LOC IF ACCESS FAILURE
12675: # (XR) VARIABLE VALUE
12676: # (WA,WB,WC) DESTROYED
12677: # (XL,RA) DESTROYED
12678: #
12679: # FAILURE CAN OCCUR IF AN INPUT ASSOCIATION CAUSES AN END
12680: # OF FILE CONDITION OR IF THE EVALUATION OF AN EXPRESSION
12681: # ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS.
12682: #
12683: acess: #prc # entry point (recursive)
12684: movl r10,r9 # copy name base
12685: addl2 r6,r9 # point to variable location
12686: movl (r9),r9 # load variable value
12687: #
12688: # LOOP HERE TO CHECK FOR SUCCESSIVE TRBLKS
12689: #
12690: acs02: cmpl (r9),$b$trt # jump if not trapped
12691: beqlu 0f
12692: jmp acs18
12693: 0:
12694: #
12695: # HERE IF TRAPPED
12696: #
12697: cmpl r9,$trbkv # jump if keyword variable
12698: bnequ 0f
12699: jmp acs12
12700: 0:
12701: cmpl r9,$trbev # jump if not expression variable
12702: bnequ acs05
12703: #
12704: # HERE FOR EXPRESSION VARIABLE, EVALUATE VARIABLE
12705: #
12706: movl 4*evexp(r10),r9 # load expression pointer
12707: clrl r7 # evaluate by value
12708: jsb evalx # evaluate expression
12709: .long acs04 # jump if evaluation failure
12710: jmp acs02 # check value for more trblks
12711: #page
12712: #
12713: # ACESS (CONTINUED)
12714: #
12715: # HERE ON READING END OF FILE
12716: #
12717: acs03: addl2 $4*num03,sp # pop trblk ptr, name base and offset
12718: movl r9,dnamp # pop unused scblk
12719: #
12720: # MERGE HERE WHEN EVALUATION OF EXPRESSION FAILS
12721: #
12722: acs04: movl (sp)+,r11 # take alternate (failure) return
12723: jmp *(r11)+
12724: #
12725: # HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
12726: #
12727: acs05: movl 4*trtyp(r9),r7 # load trap type code
12728: tstl r7 # jump if not input association
12729: beqlu 0f
12730: jmp acs10
12731: 0:
12732: tstl kvinp # ignore input assoc if input is off
12733: bnequ 0f
12734: jmp acs09
12735: 0:
12736: #
12737: # HERE FOR INPUT ASSOCIATION
12738: #
12739: movl r10,-(sp) # stack name base
12740: movl r6,-(sp) # stack name offset
12741: movl r9,-(sp) # stack trblk pointer
12742: movl 4*trfpt(r9),r10 # get file ctrl blk ptr or zero
12743: tstl r10 # jump if not standard input file
12744: bnequ acs06
12745: cmpl 4*trter(r9),$v$ter # jump if terminal
12746: bnequ 0f
12747: jmp acs21
12748: 0:
12749: #
12750: # HERE TO READ FROM STANDARD INPUT FILE
12751: #
12752: movl cswin,r6 # length for read buffer
12753: jsb alocs # build string of appropriate length
12754: jsb sysrd # read next standard input image
12755: .long acs03 # jump to fail exit if end of file
12756: jmp acs07 # else merge with other file case
12757: #
12758: # HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE
12759: #
12760: acs06: movl r10,r6 # fcblk ptr
12761: jsb sysil # get input record max length (to wa)
12762: jsb alocs # allocate string of correct size
12763: movl r10,r6 # fcblk ptr
12764: jsb sysin # call system input routine
12765: .long acs03 # jump to fail exit if end of file
12766: .long acs22 # error
12767: .long acs23 # error
12768: #page
12769: #
12770: # ACESS (CONTINUED)
12771: #
12772: # MERGE HERE AFTER OBTAINING INPUT RECORD
12773: #
12774: acs07: movl kvtrm,r7 # load trim indicator
12775: jsb trimr # trim record as required
12776: movl r9,r7 # copy result pointer
12777: movl (sp),r9 # reload pointer to trblk
12778: #
12779: # LOOP TO CHASE TO END OF TRBLK CHAIN AND STORE VALUE
12780: #
12781: acs08: movl r9,r10 # save pointer to this trblk
12782: movl 4*trnxt(r9),r9 # load forward pointer
12783: cmpl (r9),$b$trt # loop if this is another trblk
12784: beqlu acs08
12785: movl r7,4*trnxt(r10) # else store result at end of chain
12786: movl (sp)+,r9 # restore initial trblk pointer
12787: movl (sp)+,r6 # restore name offset
12788: movl (sp)+,r10 # restore name base pointer
12789: #
12790: # COME HERE TO MOVE TO NEXT TRBLK
12791: #
12792: acs09: movl 4*trnxt(r9),r9 # load forward ptr to next value
12793: jmp acs02 # back to check if trapped
12794: #
12795: # HERE TO CHECK FOR ACCESS TRACE TRBLK
12796: #
12797: acs10: cmpl r7,$trtac # loop back if not access trace
12798: beqlu 0f
12799: jmp acs09
12800: 0:
12801: tstl kvtra # ignore access trace if trace off
12802: bnequ 0f
12803: jmp acs09
12804: 0:
12805: decl kvtra # else decrement trace count
12806: tstl 4*trfnc(r9) # jump if print trace
12807: beqlu acs11
12808: #page
12809: #
12810: # ACESS (CONTINUED)
12811: #
12812: # HERE FOR FULL FUNCTION TRACE
12813: #
12814: jsb trxeq # call routine to execute trace
12815: jmp acs09 # jump for next trblk
12816: #
12817: # HERE FOR CASE OF PRINT TRACE
12818: #
12819: acs11: jsb prtsn # print statement number
12820: jsb prtnv # print name = value
12821: jmp acs09 # jump back for next trblk
12822: #
12823: # HERE FOR KEYWORD VARIABLE
12824: #
12825: acs12: movl 4*kvnum(r10),r9 # load keyword number
12826: cmpl r9,$k$v$$ # jump if not one word value
12827: bgequ acs14
12828: movl l^kvabe(r9),r5 # else load value as integer
12829: #
12830: # COMMON EXIT WITH KEYWORD VALUE AS INTEGER IN (IA)
12831: #
12832: acs13: jsb icbld # build icblk
12833: jmp acs18 # jump to exit
12834: #
12835: # HERE IF NOT ONE WORD KEYWORD VALUE
12836: #
12837: acs14: cmpl r9,$k$s$$ # jump if special case
12838: bgequ acs15
12839: subl2 $k$v$$,r9 # else get offset
12840: addl2 $ndabo,r9 # point to pattern value
12841: jmp acs18 # jump to exit
12842: #
12843: # HERE IF SPECIAL KEYWORD CASE
12844: #
12845: acs15: movl kvrtn,r10 # load rtntype in case
12846: movl kvstl,r5 # load stlimit in case
12847: subl2 $k$s$$,r9 # get case number
12848: casel r9,$0,$5 # switch on keyword number
12849: 5:
12850: .word acs16-5b # jump if alphabet
12851: .word acs17-5b # rtntype
12852: .word acs19-5b # stcount
12853: .word acs20-5b # errtext
12854: .word acs13-5b # stlimit
12855: #esw # end switch on keyword number
12856: #page
12857: #
12858: # ACESS (CONTINUED)
12859: #
12860: # ALPHABET
12861: #
12862: acs16: movl kvalp,r10 # load pointer to alphabet string
12863: #
12864: # RTNTYPE MERGES HERE
12865: #
12866: acs17: movl r10,r9 # copy string ptr to proper reg
12867: #
12868: # COMMON RETURN POINT
12869: #
12870: acs18: addl2 $4*1,(sp) # return to acess caller
12871: rsb
12872: #
12873: # HERE FOR STCOUNT (IA HAS STLIMIT)
12874: #
12875: acs19: subl2 kvstc,r5 # stcount = limit - left
12876: jmp acs13 # merge back with integer result
12877: #
12878: # ERRTEXT
12879: #
12880: acs20: movl r$etx,r9 # get errtext string
12881: jmp acs18 # merge with result
12882: #
12883: # HERE TO READ A RECORD FROM TERMINAL
12884: #
12885: acs21: movl $rilen,r6 # buffer length
12886: jsb alocs # allocate buffer
12887: jsb sysri # read record
12888: .long acs03 # endfile
12889: jmp acs07 # merge with record read
12890: #
12891: # ERROR RETURNS
12892: #
12893: acs22: movl r9,dnamp # pop unused scblk
12894: jmp er_202 # input from file caused non-recoverable error
12895: #
12896: acs23: movl r9,dnamp # pop unused scblk
12897: jmp er_203 # input file record has incorrect format
12898: #enp # end procedure acess
12899: #page
12900: #
12901: # ACOMP -- COMPARE TWO ARITHMETIC VALUES
12902: #
12903: # 1(XS) FIRST ARGUMENT
12904: # 0(XS) SECOND ARGUMENT
12905: # JSR ACOMP CALL TO COMPARE VALUES
12906: # PPM LOC TRANSFER LOC IF ARG1 IS NON-NUMERIC
12907: # PPM LOC TRANSFER LOC IF ARG2 IS NON-NUMERIC
12908: # PPM LOC TRANSFER LOC FOR ARG1 LT ARG2
12909: # PPM LOC TRANSFER LOC FOR ARG1 EQ ARG2
12910: # PPM LOC TRANSFER LOC FOR ARG1 GT ARG2
12911: # (NORMAL RETURN IS NEVER GIVEN)
12912: # (WA,WB,WC,IA,RA) DESTROYED
12913: # (XL,XR) DESTROYED
12914: #
12915: .data 1
12916: acomp_s: .long 0
12917: .text 0
12918: acomp: movl (sp)+,acomp_s # entry point
12919: jsb arith # load arithmetic operands
12920: .long acmp7 # jump if first arg non-numeric
12921: .long acmp8 # jump if second arg non-numeric
12922: .long acmp4 # jump if real arguments
12923: #
12924: # HERE FOR INTEGER ARGUMENTS
12925: #
12926: subl2 4*icval(r10),r5 # subtract to compare
12927: bvs acmp3
12928: tstl r5 # else jump if arg1 lt arg2
12929: blss acmp5
12930: tstl r5 # jump if arg1 eq arg2
12931: beql acmp2
12932: #
12933: # HERE IF ARG1 GT ARG2
12934: #
12935: acmp1: addl3 $4*4,acomp_s,r11 # take gt exit
12936: jmp *(r11)+
12937: #
12938: # HERE IF ARG1 EQ ARG2
12939: #
12940: acmp2: addl3 $4*3,acomp_s,r11 # take eq exit
12941: jmp *(r11)+
12942: #page
12943: #
12944: # ACOMP (CONTINUED)
12945: #
12946: # HERE FOR INTEGER OVERFLOW ON SUBTRACT
12947: #
12948: acmp3: movl 4*icval(r10),r5 # load second argument
12949: tstl r5 # gt if negative
12950: blss acmp1
12951: jmp acmp5 # else lt
12952: #
12953: # HERE FOR REAL OPERANDS
12954: #
12955: acmp4: subf2 4*rcval(r10),r2 # subtract to compare
12956: bvs acmp6
12957: tstf r2 # else jump if arg1 gt
12958: bgtr acmp1
12959: tstf r2 # jump if arg1 eq arg2
12960: beql acmp2
12961: #
12962: # HERE IF ARG1 LT ARG2
12963: #
12964: acmp5: addl3 $4*2,acomp_s,r11 # take lt exit
12965: jmp *(r11)+
12966: #
12967: # HERE IF OVERFLOW ON REAL SUBTRACTION
12968: #
12969: acmp6: movf 4*rcval(r10),r2 # reload arg2
12970: tstf r2 # gt if negative
12971: blss acmp1
12972: jmp acmp5 # else lt
12973: #
12974: # HERE IF ARG1 NON-NUMERIC
12975: #
12976: acmp7: movl acomp_s,r11 # take error exit
12977: jmp *(r11)+
12978: #
12979: # HERE IF ARG2 NON-NUMERIC
12980: #
12981: acmp8: addl3 $4*1,acomp_s,r11 # take error exit
12982: jmp *(r11)+
12983: #enp # end procedure acomp
12984: #page
12985: #
12986: # ALLOC ALLOCATE BLOCK OF DYNAMIC STORAGE
12987: #
12988: # (WA) LENGTH REQUIRED IN BYTES
12989: # JSR ALLOC CALL TO ALLOCATE BLOCK
12990: # (XR) POINTER TO ALLOCATED BLOCK
12991: #
12992: # A POSSIBLE ALTERNATIVE TO AOV .. AND FOLLOWING STMT IS -
12993: # MOV DNAME,XR . SUB WA,XR . BLO XR,DNAMP,ALOC2 .
12994: # MOV DNAMP,XR . ADD WA,XR
12995: #
12996: alloc: #prc # entry point
12997: #
12998: # COMMON EXIT POINT
12999: #
13000: aloc1: movl dnamp,r9 # point to next available loc
13001: addl2 r6,r9 # point past allocated block
13002: bvc 0f
13003: jmp aloc2
13004: 0:
13005: cmpl r9,dname # jump if not enough room
13006: bgtru aloc2
13007: movl r9,dnamp # store new pointer
13008: subl2 r6,r9 # point back to start of allocated bk
13009: rsb # return to caller
13010: #
13011: # HERE IF INSUFFICIENT ROOM, TRY A GARBAGE COLLECTION
13012: #
13013: aloc2: movl r7,allsv # save wb
13014: clrl r7 # set no upward move for gbcol
13015: jsb gbcol # garbage collect
13016: #
13017: # SEE IF ROOM AFTER GBCOL OR SYSMM CALL
13018: #
13019: aloc3: movl dnamp,r9 # point to first available loc
13020: addl2 r6,r9 # point past new block
13021: bvc 0f
13022: jmp alc3a
13023: 0:
13024: cmpl r9,dname # jump if there is room now
13025: blequ aloc4
13026: #
13027: # FAILED AGAIN, SEE IF WE CAN GET MORE CORE
13028: #
13029: alc3a: jsb sysmm # try to get more memory
13030: moval 0[r9],r9 # convert to baus (sgd05)
13031: addl2 r9,dname # bump ptr by amount obtained
13032: tstl r9 # jump if got more core
13033: bnequ aloc3
13034: addl2 rsmem,dname # get the reserve memory
13035: clrl rsmem # only permissible once
13036: incl errft # fatal error
13037: jmp er_204 # memory overflow
13038: #page
13039: #
13040: # HERE AFTER SUCCESSFUL GARBAGE COLLECTION
13041: #
13042: aloc4: movl r5,allia # save ia
13043: movl dname,r7 # get dynamic end adrs
13044: subl2 dnamp,r7 # compute free store
13045: ashl $-2,r7,r7 # convert bytes to words
13046: movl r7,r5 # put free store in ia
13047: mull2 alfsf,r5 # multiply by free store factor
13048: bvs aloc5
13049: movl dname,r7 # dynamic end adrs
13050: subl2 dnamb,r7 # compute total amount of dynamic
13051: ashl $-2,r7,r7 # convert to words
13052: movl r7,aldyn # store it
13053: subl2 aldyn,r5 # subtract from scaled up free store
13054: tstl r5 # jump if sufficient free store
13055: bgtr aloc5
13056: jsb sysmm # try to get more store
13057: moval 0[r9],r9 # convert to baus (sgd05)
13058: addl2 r9,dname # adjust dynamic end adrs
13059: #
13060: # MERGE TO RESTORE IA AND WB
13061: #
13062: aloc5: movl allia,r5 # recover ia
13063: movl allsv,r7 # restore wb
13064: jmp aloc1 # jump back to exit
13065: #enp # end procedure alloc
13066: #page
13067: #
13068: # ALOBF -- ALLOCATE BUFFER
13069: #
13070: # THIS ROUTINES ALLOCATES A NEW BUFFER. AS THE BFBLK
13071: # AND BCBLK COME IN PAIRS, BOTH ARE ALLOCATED HERE,
13072: # AND XR POINTS TO THE BCBLK ON RETURN. THE BFBLK
13073: # AND BCBLK ARE SET TO THE NULL BUFFER, AND THE IDVAL
13074: # IS ZERO ON RETURN.
13075: #
13076: # (WA) BUFFER SIZE IN CHARACTERS
13077: # JSR ALOBF CALL TO CREATE BUFFER
13078: # (XR) BCBLK PTR
13079: # (WA,WB) DESTROYED
13080: #
13081: alobf: #prc # entry point
13082: movl r6,r7 # hang onto allocation size
13083: movab 3+(4*bfsi$)(r6),r6 # get total block size
13084: bicl2 $3,r6
13085: cmpl r6,mxlen # check for maxlen exceeded
13086: bgequ alb01
13087: addl2 $4*bcsi$,r6 # add in allocation for bcblk
13088: jsb alloc # allocate frame
13089: movl $b$bct,(r9) # set type
13090: clrl 4*idval(r9) # no id yet
13091: clrl 4*bclen(r9) # no defined length
13092: movl r10,r6 # save xl
13093: movl r9,r10 # copy bcblk ptr
13094: addl2 $4*bcsi$,r10 # bias past partially built bcblk
13095: movl $b$bft,(r10) # set bfblk type word
13096: movl r7,4*bfalc(r10) # set allocated size
13097: movl r10,4*bcbuf(r9) # set pointer in bcblk
13098: clrl 4*bfchr(r10) # clear first word (null pad)
13099: movl r6,r10 # restore entry xl
13100: rsb # return to caller
13101: #
13102: # HERE FOR MXLEN EXCEEDED
13103: #
13104: alb01: jmp er_274 # requested buffer allocation exceeds mxlen
13105: #enp # end procedure alobf
13106: #page
13107: #
13108: # ALOCS -- ALLOCATE STRING BLOCK
13109: #
13110: # ALOCS IS USED TO BUILD A FRAME FOR A STRING BLOCK INTO
13111: # WHICH THE ACTUAL CHARACTERS ARE PLACED BY THE CALLER.
13112: # ALL STRINGS ARE CREATED WITH A CALL TO ALOCS (THE
13113: # EXCEPTIONS OCCUR IN TRIMR AND S$RPL PROCEDURES).
13114: #
13115: # (WA) LENGTH OF STRING TO BE ALLOCATED
13116: # JSR ALOCS CALL TO ALLOCATE SCBLK
13117: # (XR) POINTER TO RESULTING SCBLK
13118: # (WA) DESTROYED
13119: # (WC) CHARACTER COUNT (ENTRY VALUE OF WA)
13120: #
13121: # THE RESULTING SCBLK HAS THE TYPE WORD AND THE LENGTH
13122: # FILLED IN AND THE LAST WORD IS CLEARED TO ZERO CHARACTERS
13123: # TO ENSURE CORRECT RIGHT PADDING OF THE FINAL WORD.
13124: #
13125: alocs: #prc # entry point
13126: cmpl r6,kvmxl # jump if length exceeeds maxlength
13127: bgtru alcs2
13128: movl r6,r8 # else copy length
13129: movab 3+(4*scsi$)(r6),r6 # compute length of scblk in bytes
13130: bicl2 $3,r6
13131: movl dnamp,r9 # point to next available location
13132: addl2 r6,r9 # point past block
13133: bvc 0f
13134: jmp alcs0
13135: 0:
13136: cmpl r9,dname # jump if there is room
13137: blequ alcs1
13138: #
13139: # INSUFFICIENT MEMORY
13140: #
13141: alcs0: clrl r9 # else clear garbage xr value
13142: jsb alloc # and use standard allocator
13143: addl2 r6,r9 # point past end of block to merge
13144: #
13145: # MERGE HERE WITH XR POINTING BEYOND NEW BLOCK
13146: #
13147: alcs1: movl r9,dnamp # set updated storage pointer
13148: clrl -(r9) # store zero chars in last word
13149: subl2 $4,r6 # decrement length
13150: subl2 r6,r9 # point back to start of block
13151: movl $b$scl,(r9) # set type word
13152: movl r8,4*sclen(r9) # store length in chars
13153: rsb # return to alocs caller
13154: #
13155: # COME HERE IF STRING IS TOO LONG
13156: #
13157: alcs2: jmp er_205 # string length exceeds value of maxlngth keyword
13158: #enp # end procedure alocs
13159: #page
13160: #
13161: # ALOST -- ALLOCATE SPACE IN STATIC REGION
13162: #
13163: # (WA) LENGTH REQUIRED IN BYTES
13164: # JSR ALOST CALL TO ALLOCATE SPACE
13165: # (XR) POINTER TO ALLOCATED BLOCK
13166: # (WB) DESTROYED
13167: #
13168: # NOTE THAT THE CODING ENSURES THAT THE RESULTING VALUE
13169: # OF STATE IS ALWAYS LESS THAN DNAMB. THIS FACT IS USED
13170: # IN TESTING A VARIABLE NAME FOR BEING IN THE STATIC REGION
13171: #
13172: alost: #prc # entry point
13173: #
13174: # MERGE BACK HERE AFTER ALLOCATING NEW CHUNK
13175: #
13176: alst1: movl state,r9 # point to current end of area
13177: addl2 r6,r9 # point beyond proposed block
13178: bvc 0f
13179: jmp alst2
13180: 0:
13181: cmpl r9,dnamb # jump if overlap with dynamic area
13182: bgequ alst2
13183: movl r9,state # else store new pointer
13184: subl2 r6,r9 # point back to start of block
13185: rsb # return to alost caller
13186: #
13187: # HERE IF NO ROOM, PREPARE TO MOVE DYNAMIC STORAGE UP
13188: #
13189: alst2: movl r6,alsta # save wa
13190: cmpl r6,$4*e$sts # skip if requested chunk is large
13191: bgequ alst3
13192: movl $4*e$sts,r6 # else set to get large enough chunk
13193: #
13194: # HERE WITH AMOUNT TO MOVE UP IN WA
13195: #
13196: alst3: jsb alloc # allocate block to ensure room
13197: movl r9,dnamp # and delete it
13198: movl r6,r7 # copy move up amount
13199: jsb gbcol # call gbcol to move dynamic area up
13200: movl alsta,r6 # restore wa
13201: jmp alst1 # loop back to try again
13202: #enp # end procedure alost
13203: #page
13204: #
13205: # APNDB -- APPEND STRING TO BUFFER
13206: #
13207: # THIS ROUTINE IS USED BY BUFFER HANDLING ROUTINES TO
13208: # APPEND DATA TO AN EXISTING BFBLK.
13209: #
13210: # (XR) EXISTING BCBLK TO BE APPENDED
13211: # (XL) CONVERTABLE TO STRING
13212: # JSR APNDB CALL TO APPEND TO BUFFER
13213: # PPM LOC THREAD IF (XL) CANT BE CONVERTED
13214: # PPM LOC IF NOT ENOUGH ROOM
13215: # (WA,WB) DESTROYED
13216: #
13217: # IF MORE CHARACTERS ARE SPECIFIED THAN CAN BE INSERTED,
13218: # THEN NO ACTION IS TAKEN AND THE SECOND RETURN IS TAKEN.
13219: #
13220: apndb: #prc # entry point
13221: movl 4*bclen(r9),r6 # load offset to insert
13222: clrl r7 # replace section is null
13223: jsb insbf # call to insert at end
13224: .long apn01 # convert error
13225: .long apn02 # no room
13226: addl2 $4*2,(sp) # return to caller
13227: rsb
13228: #
13229: # HERE TO TAKE CONVERT FAILURE EXIT
13230: #
13231: apn01: movl (sp)+,r11 # return to caller alternate
13232: jmp *(r11)+
13233: #
13234: # HERE FOR NO FIT EXIT
13235: #
13236: apn02: addl3 $4*1,(sp)+,r11 # alternate exit to caller
13237: jmp *(r11)+
13238: #enp # end procedure apndb
13239: #page
13240: #
13241: # ARITH -- FETCH ARITHMETIC OPERANDS
13242: #
13243: # ARITH IS USED BY FUNCTIONS AND OPERATORS WHICH EXPECT
13244: # TWO NUMERIC ARGUMENTS (OPERANDS) WHICH MUST BOTH BE
13245: # INTEGER OR BOTH BE REAL. ARITH FETCHES TWO ARGUMENTS FROM
13246: # THE STACK AND PERFORMS ANY NECESSARY CONVERSIONS.
13247: #
13248: # 1(XS) FIRST ARGUMENT (LEFT OPERAND)
13249: # 0(XS) SECOND ARGUMENT (RIGHT OPERAND)
13250: # JSR ARITH CALL TO FETCH NUMERIC ARGUMENTS
13251: # PPM LOC TRANSFER LOC FOR OPND 1 NON-NUMERIC
13252: # PPM LOC TRANSFER LOC FOR OPND 2 NON-NUMERIC
13253: # PPM LOC TRANSFER LOC FOR REAL OPERANDS
13254: #
13255: # FOR INTEGER ARGS, CONTROL RETURNS PAST THE PARAMETERS
13256: #
13257: # (IA) LEFT OPERAND VALUE
13258: # (XR) PTR TO ICBLK FOR LEFT OPERAND
13259: # (XL) PTR TO ICBLK FOR RIGHT OPERAND
13260: # (XS) POPPED TWICE
13261: # (WA,WB,RA) DESTROYED
13262: #
13263: # FOR REAL ARGUMENTS, CONTROL RETURNS TO THE LOCATION
13264: # SPECIFIED BY THE THIRD PARAMETER.
13265: #
13266: # (RA) LEFT OPERAND VALUE
13267: # (XR) PTR TO RCBLK FOR LEFT OPERAND
13268: # (XL) PTR TO RCBLK FOR RIGHT OPERAND
13269: # (WA,WB,WC) DESTROYED
13270: # (XS) POPPED TWICE
13271: #page
13272: #
13273: # ARITH (CONTINUED)
13274: #
13275: # ENTRY POINT
13276: #
13277: .data 1
13278: arith_s: .long 0
13279: .text 0
13280: arith: movl (sp)+,arith_s # entry point
13281: movl (sp)+,r10 # load right operand
13282: movl (sp)+,r9 # load left operand
13283: movl (r10),r6 # get right operand type word
13284: cmpl r6,$b$icl # jump if integer
13285: beqlu arth1
13286: cmpl r6,$b$rcl # jump if real
13287: beqlu arth4
13288: movl r9,-(sp) # else replace left arg on stack
13289: movl r10,r9 # copy left arg pointer
13290: jsb gtnum # convert to numeric
13291: .long arth6 # jump if unconvertible
13292: movl r9,r10 # else copy converted result
13293: movl (r10),r6 # get right operand type word
13294: movl (sp)+,r9 # reload left argument
13295: cmpl r6,$b$rcl # jump if right arg is real
13296: beqlu arth4
13297: #
13298: # HERE IF RIGHT ARG IS AN INTEGER
13299: #
13300: arth1: cmpl (r9),$b$icl # jump if left arg not integer
13301: bnequ arth3
13302: #
13303: # EXIT FOR INTEGER CASE
13304: #
13305: arth2: movl 4*icval(r9),r5 # load left operand value
13306: addl3 $4*3,arith_s,r11 # return to arith caller
13307: jmp (r11)
13308: #
13309: # HERE FOR RIGHT OPERAND INTEGER, LEFT OPERAND NOT
13310: #
13311: arth3: jsb gtnum # convert left arg to numeric
13312: .long arth7 # jump if not convertible
13313: cmpl r6,$b$icl # jump back if integer-integer
13314: beqlu arth2
13315: #
13316: # HERE WE MUST CONVERT REAL-INTEGER TO REAL-REAL
13317: #
13318: movl r9,-(sp) # put left arg back on stack
13319: movl 4*icval(r10),r5 # load right argument value
13320: cvtlf r5,r2 # convert to real
13321: jsb rcbld # get real block for right arg, merge
13322: movl r9,r10 # copy right arg ptr
13323: movl (sp)+,r9 # load left argument
13324: jmp arth5 # merge for real-real case
13325: #page
13326: #
13327: # ARITH (CONTINUED)
13328: #
13329: # HERE IF RIGHT ARGUMENT IS REAL
13330: #
13331: arth4: cmpl (r9),$b$rcl # jump if left arg real
13332: beqlu arth5
13333: jsb gtrea # else convert to real
13334: .long arth7 # error if unconvertible
13335: #
13336: # HERE FOR REAL-REAL
13337: #
13338: arth5: movf 4*rcval(r9),r2 # load left operand value
13339: addl3 $4*2,arith_s,r11 # take real-real exit
13340: jmp *(r11)+
13341: #
13342: # HERE FOR ERROR CONVERTING RIGHT ARGUMENT
13343: #
13344: arth6: addl2 $4,sp # pop unwanted left arg
13345: addl3 $4*1,arith_s,r11 # take appropriate error exit
13346: jmp *(r11)+
13347: #
13348: # HERE FOR ERROR CONVERTING LEFT OPERAND
13349: #
13350: arth7: movl arith_s,r11 # take appropriate error return
13351: jmp *(r11)+
13352: #enp # end procedure arith
13353: #page
13354: #
13355: # ASIGN -- PERFORM ASSIGNMENT
13356: #
13357: # ASIGN PERFORMS THE ASSIGNMENT OF A VALUE TO A VARIABLE
13358: # WITH APPROPRIATE CHECKS FOR OUTPUT ASSOCIATIONS AND
13359: # VALUE TRACE ASSOCIATIONS WHICH ARE EXECUTED AS REQUIRED.
13360: # ASIGN ALSO HANDLES THE SPECIAL CASES OF ASSIGNMENT TO
13361: # PATTERN AND EXPRESSION VARIABLES.
13362: #
13363: # (WB) VALUE TO BE ASSIGNED
13364: # (XL) BASE POINTER FOR VARIABLE
13365: # (WA) OFFSET FOR VARIABLE
13366: # JSR ASIGN CALL TO ASSIGN VALUE TO VARIABLE
13367: # PPM LOC TRANSFER LOC FOR FAILURE
13368: # (XR,XL,WA,WB,WC) DESTROYED
13369: # (RA) DESTROYED
13370: #
13371: # FAILURE OCCURS IF THE EVALUATION OF AN EXPRESSION
13372: # ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS.
13373: #
13374: asign: #prc # entry point (recursive)
13375: #
13376: # MERGE BACK HERE TO ASSIGN RESULT TO EXPRESSION VARIABLE.
13377: #
13378: asg01: addl2 r6,r10 # point to variable value
13379: movl (r10),r9 # load variable value
13380: cmpl (r9),$b$trt # jump if trapped
13381: beqlu asg02
13382: movl r7,(r10) # else perform assignment
13383: clrl r10 # clear garbage value in xl
13384: addl2 $4*1,(sp) # and return to asign caller
13385: rsb
13386: #
13387: # HERE IF VALUE IS TRAPPED
13388: #
13389: asg02: subl2 r6,r10 # restore name base
13390: cmpl r9,$trbkv # jump if keyword variable
13391: bnequ 0f
13392: jmp asg14
13393: 0:
13394: cmpl r9,$trbev # jump if not expression variable
13395: bnequ asg04
13396: #
13397: # HERE FOR ASSIGNMENT TO EXPRESSION VARIABLE
13398: #
13399: movl 4*evexp(r10),r9 # point to expression
13400: movl r7,-(sp) # store value to assign on stack
13401: movl $num01,r7 # set for evaluation by name
13402: jsb evalx # evaluate expression by name
13403: .long asg03 # jump if evaluation fails
13404: movl (sp)+,r7 # else reload value to assign
13405: jmp asg01 # loop back to perform assignment
13406: #page
13407: #
13408: # ASIGN (CONTINUED)
13409: #
13410: # HERE FOR FAILURE DURING EXPRESSION EVALUATION
13411: #
13412: asg03: addl2 $4,sp # remove stacked value entry
13413: movl (sp)+,r11 # take failure exit
13414: jmp *(r11)+
13415: #
13416: # HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
13417: #
13418: asg04: movl r9,-(sp) # save ptr to first trblk
13419: #
13420: # LOOP TO CHASE DOWN TRBLK CHAIN AND ASSIGN VALUE AT END
13421: #
13422: asg05: movl r9,r8 # save ptr to this trblk
13423: movl 4*trnxt(r9),r9 # point to next trblk
13424: cmpl (r9),$b$trt # loop back if another trblk
13425: beqlu asg05
13426: movl r8,r9 # else point back to last trblk
13427: movl r7,4*trval(r9) # store value at end of chain
13428: movl (sp)+,r9 # restore ptr to first trblk
13429: #
13430: # LOOP TO PROCESS TRBLK ENTRIES ON CHAIN
13431: #
13432: asg06: movl 4*trtyp(r9),r7 # load type code of trblk
13433: cmpl r7,$trtvl # jump if value trace
13434: beqlu asg08
13435: cmpl r7,$trtou # jump if output association
13436: beqlu asg10
13437: #
13438: # HERE TO MOVE TO NEXT TRBLK ON CHAIN
13439: #
13440: asg07: movl 4*trnxt(r9),r9 # point to next trblk on chain
13441: cmpl (r9),$b$trt # loop back if another trblk
13442: beqlu asg06
13443: addl2 $4*1,(sp) # else end of chain, return to caller
13444: rsb
13445: #
13446: # HERE TO PROCESS VALUE TRACE
13447: #
13448: asg08: tstl kvtra # ignore value trace if trace off
13449: beqlu asg07
13450: decl kvtra # else decrement trace count
13451: tstl 4*trfnc(r9) # jump if print trace
13452: beqlu asg09
13453: jsb trxeq # else execute function trace
13454: jmp asg07 # and loop back
13455: #page
13456: #
13457: # ASIGN (CONTINUED)
13458: #
13459: # HERE FOR PRINT TRACE
13460: #
13461: asg09: jsb prtsn # print statement number
13462: jsb prtnv # print name = value
13463: jmp asg07 # loop back for next trblk
13464: #
13465: # HERE FOR OUTPUT ASSOCIATION
13466: #
13467: asg10: tstl kvoup # ignore output assoc if output off
13468: beqlu asg07
13469: movl r9,r10 # else copy trblk pointer
13470: movl 4*trval(r8),-(sp)# stack value to output (sgd01)
13471: jsb gtstg # convert to string
13472: .long asg12 # get datatype name if unconvertible
13473: #
13474: # MERGE WITH STRING FOR OUTPUT
13475: #
13476: asg11: movl 4*trfpt(r10),r6 # fcblk ptr
13477: tstl r6 # jump if standard output file
13478: beqlu asg13
13479: #
13480: # HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE
13481: #
13482: jsb sysou # call system output routine
13483: .long er_206 # output caused file overflow
13484: .long er_207 # output caused non-recoverable error
13485: addl2 $4*1,(sp) # else all done, return to caller
13486: rsb
13487: #
13488: # IF NOT PRINTABLE, GET DATATYPE NAME INSTEAD
13489: #
13490: asg12: jsb dtype # call datatype routine
13491: jmp asg11 # merge
13492: #
13493: # HERE TO PRINT A STRING ON THE PRINTER
13494: #
13495: asg13: jsb prtst # print string value
13496: cmpl 4*trter(r10),$v$ter # jump if terminal output
13497: bnequ 0f
13498: jmp asg20
13499: 0:
13500: jsb prtnl # end of line
13501: addl2 $4*1,(sp) # return to caller
13502: rsb
13503: #page
13504: #
13505: # ASIGN (CONTINUED)
13506: #
13507: # HERE FOR KEYWORD ASSIGNMENT
13508: #
13509: asg14: movl 4*kvnum(r10),r10# load keyword number
13510: cmpl r10,$k$etx # jump if errtext
13511: bnequ 0f
13512: jmp asg19
13513: 0:
13514: movl r7,r9 # copy value to be assigned
13515: jsb gtint # convert to integer
13516: .long er_208 # keyword value assigned is not integer
13517: movl 4*icval(r9),r5 # else load value
13518: cmpl r10,$k$stl # jump if special case of stlimit
13519: beqlu asg16
13520: movl r5,r6 # else get addr integer, test ovflow
13521: bgeq 0f
13522: jmp asg18
13523: 0:
13524: cmpl r6,mxlen # fail if too large
13525: bgequ asg18
13526: cmpl r10,$k$ert # jump if special case of errtype
13527: beqlu asg17
13528: cmpl r10,$k$pfl # jump if special case of profile
13529: beqlu asg21
13530: cmpl r10,$k$p$$ # jump unless protected
13531: blssu asg15
13532: jmp er_209 # keyword in assignment is protected
13533: #
13534: # HERE TO DO ASSIGNMENT IF NOT PROTECTED
13535: #
13536: asg15: movl r6,l^kvabe(r10) # store new value
13537: addl2 $4*1,(sp) # return to asign caller
13538: rsb
13539: #
13540: # HERE FOR SPECIAL CASE OF STLIMIT
13541: #
13542: # SINCE STCOUNT IS MAINTAINED AS (STLIMIT-STCOUNT)
13543: # IT IS ALSO NECESSARY TO MODIFY STCOUNT APPROPRIATELY.
13544: #
13545: asg16: subl2 kvstl,r5 # subtract old limit
13546: addl2 kvstc,r5 # add old counter
13547: movl r5,kvstc # store new counter value
13548: movl 4*icval(r9),r5 # reload new limit value
13549: movl r5,kvstl # store new limit value
13550: addl2 $4*1,(sp) # return to asign caller
13551: rsb
13552: #
13553: # HERE FOR SPECIAL CASE OF ERRTYPE
13554: #
13555: asg17: cmpl r6,$nini9 # ok to signal if in range
13556: bgtru 0f
13557: jmp error
13558: 0:
13559: #
13560: # HERE IF VALUE ASSIGNED IS OUT OF RANGE
13561: #
13562: asg18: jmp er_210 # keyword value assigned is negative or too large
13563: #
13564: # HERE FOR SPECIAL CASE OF ERRTEXT
13565: #
13566: asg19: movl r7,-(sp) # stack value
13567: jsb gtstg # convert to string
13568: .long er_211 # value assigned to keyword errtext not a string
13569: movl r9,r$etx # make assignment
13570: addl2 $4*1,(sp) # return to caller
13571: rsb
13572: #
13573: # PRINT STRING TO TERMINAL
13574: #
13575: asg20: jsb prttr # print
13576: addl2 $4*1,(sp) # return
13577: rsb
13578: #
13579: # HERE FOR KEYWORD PROFILE
13580: #
13581: asg21: cmpl r6,$num02 # moan if not 0,1, or 2
13582: bgtru asg18
13583: tstl r6 # just assign if zero
13584: beqlu asg15
13585: tstl pfdmp # branch if first assignment
13586: beqlu asg22
13587: cmpl r6,pfdmp # also if same value as before
13588: beqlu asg23
13589: jmp er_268 # inconsistent value assigned to keyword profile
13590: #
13591: asg22: movl r6,pfdmp # note value on first assignment
13592: asg23: jsb systm # get the time
13593: movl r5,pfstm # fudge some kind of start time
13594: jmp asg15 # and go assign
13595: #enp # end procedure asign
13596: #page
13597: #
13598: # ASINP -- ASSIGN DURING PATTERN MATCH
13599: #
13600: # ASINP IS LIKE ASIGN AND HAS A SIMILAR CALLING SEQUENCE
13601: # AND EFFECT. THE DIFFERENCE IS THAT THE GLOBAL PATTERN
13602: # VARIABLES ARE SAVED AND RESTORED IF REQUIRED.
13603: #
13604: # (XL) BASE POINTER FOR VARIABLE
13605: # (WA) OFFSET FOR VARIABLE
13606: # (WB) VALUE TO BE ASSIGNED
13607: # JSR ASINP CALL TO ASSIGN VALUE TO VARIABLE
13608: # PPM LOC TRANSFER LOC IF FAILURE
13609: # (XR,XL) DESTROYED
13610: # (WA,WB,WC,RA) DESTROYED
13611: #
13612: asinp: #prc # entry point, recursive
13613: addl2 r6,r10 # point to variable
13614: movl (r10),r9 # load current contents
13615: cmpl (r9),$b$trt # jump if trapped
13616: beqlu asnp1
13617: movl r7,(r10) # else perform assignment
13618: clrl r10 # clear garbage value in xl
13619: addl2 $4*1,(sp) # return to asinp caller
13620: rsb
13621: #
13622: # HERE IF VARIABLE IS TRAPPED
13623: #
13624: asnp1: subl2 r6,r10 # restore base pointer
13625: movl pmssl,-(sp) # stack subject string length
13626: movl pmhbs,-(sp) # stack history stack base ptr
13627: movl r$pms,-(sp) # stack subject string pointer
13628: movl pmdfl,-(sp) # stack dot flag
13629: jsb asign # call full-blown assignment routine
13630: .long asnp2 # jump if failure
13631: movl (sp)+,pmdfl # restore dot flag
13632: movl (sp)+,r$pms # restore subject string pointer
13633: movl (sp)+,pmhbs # restore history stack base pointer
13634: movl (sp)+,pmssl # restore subject string length
13635: addl2 $4*1,(sp) # return to asinp caller
13636: rsb
13637: #
13638: # HERE IF FAILURE IN ASIGN CALL
13639: #
13640: asnp2: movl (sp)+,pmdfl # restore dot flag
13641: movl (sp)+,r$pms # restore subject string pointer
13642: movl (sp)+,pmhbs # restore history stack base pointer
13643: movl (sp)+,pmssl # restore subject string length
13644: movl (sp)+,r11 # take failure exit
13645: jmp *(r11)+
13646: #enp # end procedure asinp
13647: #page
13648: #
13649: # BLKLN -- DETERMINE LENGTH OF BLOCK
13650: #
13651: # BLKLN DETERMINES THE LENGTH OF A BLOCK IN DYNAMIC STORE.
13652: #
13653: # (WA) FIRST WORD OF BLOCK
13654: # (XR) POINTER TO BLOCK
13655: # JSR BLKLN CALL TO GET BLOCK LENGTH
13656: # (WA) LENGTH OF BLOCK IN BYTES
13657: # (XL) DESTROYED
13658: #
13659: # BLKLN IS USED BY THE GARBAGE COLLECTOR AND IS NOT
13660: # PERMITTED TO CALL GBCOL DIRECTLY OR INDIRECTLY.
13661: #
13662: # THE FIRST WORD STORED IN THE BLOCK (I.E. AT XR) MAY
13663: # BE ANYTHING, BUT THE CONTENTS OF WA MUST BE CORRECT.
13664: #
13665: blkln: #prc # entry point
13666: movl r6,r10 # copy first word
13667: movzwl -2(r10),r10 # get entry id (bl$xx)
13668: casel r10,$0,$bl$$$ # switch on block type
13669: 5:
13670: .word bln01-5b # arblk
13671: .word bln04-5b # bcblk
13672: .word bln01-5b # cdblk
13673: .word bln01-5b # exblk
13674: .word bln07-5b # icblk
13675: .word bln03-5b # nmblk
13676: .word bln02-5b # p0blk
13677: .word bln03-5b # p1blk
13678: .word bln04-5b # p2blk
13679: .word bln09-5b # rcblk
13680: .word bln10-5b # scblk
13681: .word bln02-5b # seblk
13682: .word bln01-5b # tbblk
13683: .word bln01-5b # vcblk
13684: .word bln00-5b
13685: .word bln00-5b
13686: .word bln08-5b # pdblk
13687: .word bln05-5b # trblk
13688: .word bln11-5b # bfblk
13689: .word bln00-5b
13690: .word bln00-5b
13691: .word bln06-5b # ctblk
13692: .word bln01-5b # dfblk
13693: .word bln01-5b # efblk
13694: .word bln03-5b # evblk
13695: .word bln05-5b # ffblk
13696: .word bln03-5b # kvblk
13697: .word bln01-5b # pfblk
13698: .word bln04-5b # teblk
13699: #esw # end of jump table on block type
13700: #page
13701: #
13702: # BLKLN (CONTINUED)
13703: #
13704: # HERE FOR BLOCKS WITH LENGTH IN SECOND WORD
13705: #
13706: bln00: movl 4*1(r9),r6 # load length
13707: rsb # return to blkln caller
13708: #
13709: # HERE FOR LENGTH IN THIRD WORD (AR,CD,DF,EF,EX,PF,TB,VC)
13710: #
13711: bln01: movl 4*2(r9),r6 # load length from third word
13712: rsb # return to blkln caller
13713: #
13714: # HERE FOR TWO WORD BLOCKS (P0,SE)
13715: #
13716: bln02: movl $4*num02,r6 # load length (two words)
13717: rsb # return to blkln caller
13718: #
13719: # HERE FOR THREE WORD BLOCKS (NM,P1,EV,KV)
13720: #
13721: bln03: movl $4*num03,r6 # load length (three words)
13722: rsb # return to blkln caller
13723: #
13724: # HERE FOR FOUR WORD BLOCKS (P2,TE,BC)
13725: #
13726: bln04: movl $4*num04,r6 # load length (four words)
13727: rsb # return to blkln caller
13728: #
13729: # HERE FOR FIVE WORD BLOCKS (FF,TR)
13730: #
13731: bln05: movl $4*num05,r6 # load length
13732: rsb # return to blkln caller
13733: #page
13734: #
13735: # BLKLN (CONTINUED)
13736: #
13737: # HERE FOR CTBLK
13738: #
13739: bln06: movl $4*ctsi$,r6 # set size of ctblk
13740: rsb # return to blkln caller
13741: #
13742: # HERE FOR ICBLK
13743: #
13744: bln07: movl $4*icsi$,r6 # set size of icblk
13745: rsb # return to blkln caller
13746: #
13747: # HERE FOR PDBLK
13748: #
13749: bln08: movl 4*pddfp(r9),r10 # point to dfblk
13750: movl 4*dfpdl(r10),r6 # load pdblk length from dfblk
13751: rsb # return to blkln caller
13752: #
13753: # HERE FOR RCBLK
13754: #
13755: bln09: movl $4*rcsi$,r6 # set size of rcblk
13756: rsb # return to blkln caller
13757: #
13758: # HERE FOR SCBLK
13759: #
13760: bln10: movl 4*sclen(r9),r6 # load length in characters
13761: movab 3+(4*scsi$)(r6),r6 # calculate length in bytes
13762: bicl2 $3,r6
13763: rsb # return to blkln caller
13764: #
13765: # HERE FOR BFBLK
13766: #
13767: bln11: movl 4*bfalc(r9),r6 # get allocation in bytes
13768: movab 3+(4*bfsi$)(r6),r6 # calculate length in bytes
13769: bicl2 $3,r6
13770: rsb # return to blkln caller
13771: #enp # end procedure blkln
13772: #page
13773: #
13774: # COPYB -- COPY A BLOCK
13775: #
13776: # (XS) BLOCK TO BE COPIED
13777: # JSR COPYB CALL TO COPY BLOCK
13778: # PPM LOC RETURN IF BLOCK HAS NO IDVAL FIELD
13779: # NORMAL RETURN IF IDVAL FIELD
13780: # (XR) COPY OF BLOCK
13781: # (XS) POPPED
13782: # (XL,WA,WB,WC) DESTROYED
13783: #
13784: .data 1
13785: copyb_s: .long 0
13786: .text 0
13787: copyb: movl (sp)+,copyb_s # entry point
13788: movl (sp),r9 # load argument
13789: cmpl r9,$nulls # return argument if it is null
13790: bnequ 0f
13791: jmp cop10
13792: 0:
13793: movl (r9),r6 # else load type word
13794: movl r6,r7 # copy type word
13795: jsb blkln # get length of argument block
13796: movl r9,r10 # copy pointer
13797: jsb alloc # allocate block of same size
13798: movl r9,(sp) # store pointer to copy
13799: jsb sbmvw # copy contents of old block to new
13800: movl (sp),r9 # reload pointer to start of copy
13801: cmpl r7,$b$tbt # jump if table
13802: beqlu cop05
13803: cmpl r7,$b$vct # jump if vector
13804: beqlu cop01
13805: cmpl r7,$b$pdt # jump if program defined
13806: beqlu cop01
13807: cmpl r7,$b$bct # jump if buffer
13808: bnequ 0f
13809: jmp cop11
13810: 0:
13811: cmpl r7,$b$art # return copy if not array
13812: beqlu 0f
13813: jmp cop10
13814: 0:
13815: #
13816: # HERE FOR ARRAY (ARBLK)
13817: #
13818: addl2 4*arofs(r9),r9 # point to prototype field
13819: jmp cop02 # jump to merge
13820: #
13821: # HERE FOR VECTOR, PROGRAM DEFINED
13822: #
13823: cop01: addl2 $4*pdfld,r9 # point to pdfld = vcvls
13824: #
13825: # MERGE HERE FOR ARBLK, VCBLK, PDBLK TO DELETE TRAP
13826: # BLOCKS FROM ALL VALUE FIELDS (THE COPY IS UNTRAPPED)
13827: #
13828: cop02: movl (r9),r10 # load next pointer
13829: #
13830: # LOOP TO GET VALUE AT END OF TRBLK CHAIN
13831: #
13832: cop03: cmpl (r10),$b$trt # jump if not trapped
13833: bnequ cop04
13834: movl 4*trval(r10),r10# else point to next value
13835: jmp cop03 # and loop back
13836: #page
13837: #
13838: # COPYB (CONTINUED)
13839: #
13840: # HERE WITH UNTRAPPED VALUE IN XL
13841: #
13842: cop04: movl r10,(r9)+ # store real value, bump pointer
13843: cmpl r9,dnamp # loop back if more to go
13844: bnequ cop02
13845: jmp cop09 # else jump to exit
13846: #
13847: # HERE TO COPY A TABLE
13848: #
13849: cop05: clrl 4*idval(r9) # zero id to stop dump blowing up
13850: movl $4*tesi$,r6 # set size of teblk
13851: movl $4*tbbuk,r8 # set initial offset
13852: #
13853: # LOOP THROUGH BUCKETS IN TABLE
13854: #
13855: cop06: movl (sp),r9 # load table pointer
13856: cmpl r8,4*tblen(r9) # jump to exit if all done
13857: beqlu cop09
13858: addl2 r8,r9 # else point to next bucket header
13859: addl2 $4,r8 # bump offset
13860: subl2 $4*tenxt,r9 # subtract link offset to merge
13861: #
13862: # LOOP THROUGH TEBLKS ON ONE CHAIN
13863: #
13864: cop07: movl 4*tenxt(r9),r10 # load pointer to next teblk
13865: movl (sp),4*tenxt(r9)# set end of chain pointer in case
13866: cmpl (r10),$b$tbt # back for next bucket if chain end
13867: beqlu cop06
13868: movl r9,-(sp) # else stack ptr to previous block
13869: movl $4*tesi$,r6 # set size of teblk
13870: jsb alloc # allocate new teblk
13871: movl r9,r7 # save ptr to new teblk
13872: jsb sbmvw # copy old teblk to new teblk
13873: movl r7,r9 # restore pointer to new teblk
13874: movl (sp)+,r10 # restore pointer to previous block
13875: movl r9,4*tenxt(r10) # link new block to previous
13876: movl r9,r10 # copy pointer to new block
13877: #
13878: # LOOP TO SET REAL VALUE AFTER REMOVING TRAP CHAIN
13879: #
13880: cop08: movl 4*teval(r10),r10# load value
13881: cmpl (r10),$b$trt # loop back if trapped
13882: beqlu cop08
13883: movl r10,4*teval(r9) # store untrapped value in teblk
13884: jmp cop07 # back for next teblk
13885: #
13886: # COMMON EXIT POINT
13887: #
13888: cop09: movl (sp)+,r9 # load pointer to block
13889: addl3 $4*1,copyb_s,r11 # return
13890: jmp (r11)
13891: #
13892: # ALTERNATIVE RETURN
13893: #
13894: cop10: movl copyb_s,r11 # return
13895: jmp *(r11)+
13896: #page
13897: #
13898: # HERE TO COPY BUFFER
13899: #
13900: cop11: movl 4*bcbuf(r9),r10 # get bfblk ptr
13901: movl 4*bfalc(r10),r6 # get allocation
13902: movab 3+(4*bfsi$)(r6),r6 # set total size
13903: bicl2 $3,r6
13904: movl r9,r10 # save bcblk ptr
13905: jsb alloc # allocate bfblk
13906: movl 4*bcbuf(r10),r7 # get old bfblk
13907: movl r9,4*bcbuf(r10) # set pointer to new bfblk
13908: movl r7,r10 # point to old bfblk
13909: jsb sbmvw # copy bfblk too
13910: clrl r10 # clear rubbish ptr
13911: jmp cop09 # branch to exit
13912: #enp # end procedure copyb
13913: #
13914: # CDGCG -- GENERATE CODE FOR COMPLEX GOTO
13915: #
13916: # USED BY CMPIL TO PROCESS COMPLEX GOTO TREE
13917: #
13918: # (WB) MUST BE COLLECTABLE
13919: # (XR) EXPRESSION POINTER
13920: # JSR CDGCG CALL TO GENERATE COMPLEX GOTO
13921: # (XL,XR,WA) DESTROYED
13922: #
13923: cdgcg: #prc # entry point
13924: movl 4*cmopn(r9),r10 # get unary goto operator
13925: movl 4*cmrop(r9),r9 # point to goto operand
13926: cmpl r10,$opdvd # jump if direct goto
13927: beqlu cdgc2
13928: jsb cdgnm # generate opnd by name if not direct
13929: #
13930: # RETURN POINT
13931: #
13932: cdgc1: movl r10,r6 # goto operator
13933: jsb cdwrd # generate it
13934: rsb # return to caller
13935: #
13936: # DIRECT GOTO
13937: #
13938: cdgc2: jsb cdgvl # generate operand by value
13939: jmp cdgc1 # merge to return
13940: #enp # end procedure cdgcg
13941: #page
13942: #
13943: # CDGEX -- BUILD EXPRESSION BLOCK
13944: #
13945: # CDGEX IS PASSED A POINTER TO AN EXPRESSION TREE (SEE
13946: # EXPAN) AND RETURNS AN EXPRESSION (SEBLK OR EXBLK).
13947: #
13948: # (WC) SOME COLLECTABLE VALUE
13949: # (WB) INTEGER IN RANGE 0 LE X LE MXLEN
13950: # (XL) PTR TO EXPRESSION TREE
13951: # JSR CDGEX CALL TO BUILD EXPRESSION
13952: # (XR) PTR TO SEBLK OR EXBLK
13953: # (XL,WA,WB) DESTROYED
13954: #
13955: cdgex: #prc # entry point, recursive
13956: cmpl (r10),$b$vr$ # jump if not variable
13957: blequ cdgx1
13958: #
13959: # HERE FOR NATURAL VARIABLE, BUILD SEBLK
13960: #
13961: movl $4*sesi$,r6 # set size of seblk
13962: jsb alloc # allocate space for seblk
13963: movl $b$sel,(r9) # set type word
13964: movl r10,4*sevar(r9) # store vrblk pointer
13965: rsb # return to cdgex caller
13966: #
13967: # HERE IF NOT VARIABLE, BUILD EXBLK
13968: #
13969: cdgx1: movl r10,r9 # copy tree pointer
13970: movl r8,-(sp) # save wc
13971: movl cwcof,r10 # save current offset
13972: movl (r9),r6 # get type word
13973: cmpl r6,$b$cmt # call by value if not cmblk
13974: bnequ cdgx2
13975: cmpl 4*cmtyp(r9),$c$$nm # jump if cmblk only by value
13976: bgequ cdgx2
13977: #page
13978: #
13979: # CDGEX (CONTINUED)
13980: #
13981: # HERE IF EXPRESSION CAN BE EVALUATED BY NAME
13982: #
13983: jsb cdgnm # generate code by name
13984: movl $ornm$,r6 # load return by name word
13985: jmp cdgx3 # merge with value case
13986: #
13987: # HERE IF EXPRESSION CAN ONLY BE EVALUATED BY VALUE
13988: #
13989: cdgx2: jsb cdgvl # generate code by value
13990: movl $orvl$,r6 # load return by value word
13991: #
13992: # MERGE HERE TO CONSTRUCT EXBLK
13993: #
13994: cdgx3: jsb cdwrd # generate return word
13995: jsb exbld # build exblk
13996: movl (sp)+,r8 # restore wc
13997: rsb # return to cdgex caller
13998: #enp # end procedure cdgex
13999: #page
14000: #
14001: # CDGNM -- GENERATE CODE BY NAME
14002: #
14003: # CDGNM IS CALLED DURING THE COMPILATION PROCESS TO
14004: # GENERATE CODE BY NAME FOR AN EXPRESSION. SEE CDBLK
14005: # DESCRIPTION FOR DETAILS OF CODE GENERATED. THE INPUT
14006: # TO CDGNM IS AN EXPRESSION TREE AS GENERATED BY EXPAN.
14007: #
14008: # CDGNM IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING
14009: # RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS.
14010: #
14011: # (WB) INTEGER IN RANGE 0 LE N LE DNAMB
14012: # (XR) PTR TO TREE GENERATED BY EXPAN
14013: # (WC) CONSTANT FLAG (SEE BELOW)
14014: # JSR CDGNM CALL TO GENERATE CODE BY NAME
14015: # (XR,WA) DESTROYED
14016: # (WC) SET NON-ZERO IF NON-CONSTANT
14017: #
14018: # WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE
14019: # EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE
14020: # EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED.
14021: #
14022: # THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD).
14023: #
14024: cdgnm: #prc # entry point, recursive
14025: movl r10,-(sp) # save entry xl
14026: movl r7,-(sp) # save entry wb
14027: jsb sbchk # check for stack overflow
14028: movl (r9),r6 # load type word
14029: cmpl r6,$b$cmt # jump if cmblk
14030: beqlu cgn04
14031: cmpl r6,$b$vr$ # jump if simple variable
14032: blssu 0f
14033: jmp cgn02
14034: 0:
14035: #
14036: # MERGE HERE FOR OPERAND YIELDING VALUE (E.G. CONSTANT)
14037: #
14038: cgn01: jmp er_212 # syntax error. value used where name is required
14039: #
14040: # HERE FOR NATURAL VARIABLE REFERENCE
14041: #
14042: cgn02: movl $olvn$,r6 # load variable load call
14043: jsb cdwrd # generate it
14044: movl r9,r6 # copy vrblk pointer
14045: jsb cdwrd # generate vrblk pointer
14046: #page
14047: #
14048: # CDGNM (CONTINUED)
14049: #
14050: # HERE TO EXIT WITH WC SET CORRECTLY
14051: #
14052: cgn03: movl (sp)+,r7 # restore entry wb
14053: movl (sp)+,r10 # restore entry xl
14054: rsb # return to cdgnm caller
14055: #
14056: # HERE FOR CMBLK
14057: #
14058: cgn04: movl r9,r10 # copy cmblk pointer
14059: movl 4*cmtyp(r9),r9 # load cmblk type
14060: cmpl r9,$c$$nm # error if not name operand
14061: bgequ cgn01
14062: casel r9,$0,$c$$nm # else switch on type
14063: 5:
14064: .word cgn05-5b # array reference
14065: .word cgn08-5b # function call
14066: .word cgn09-5b # deferred expression
14067: .word cgn10-5b # indirect reference
14068: .word cgn11-5b # keyword reference
14069: .word cgn08-5b # undefined binary op
14070: .word cgn08-5b # undefined unary op
14071: #esw # end switch on cmblk type
14072: #
14073: # HERE TO GENERATE CODE FOR ARRAY REFERENCE
14074: #
14075: cgn05: movl $4*cmopn,r7 # point to array operand
14076: #
14077: # LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
14078: #
14079: cgn06: jsb cmgen # generate code for next operand
14080: movl 4*cmlen(r10),r8 # load length of cmblk
14081: cmpl r7,r8 # loop till all generated
14082: blssu cgn06
14083: #
14084: # GENERATE APPROPRIATE ARRAY CALL
14085: #
14086: movl $oaon$,r6 # load one-subscript case call
14087: cmpl r8,$4*cmar1 # jump to exit if one subscript case
14088: beqlu cgn07
14089: movl $oamn$,r6 # else load multi-subscript case call
14090: jsb cdwrd # generate call
14091: movl r8,r6 # copy cmblk length
14092: ashl $-2,r6,r6 # convert to words
14093: subl2 $cmvls,r6 # calculate number of subscripts
14094: #page
14095: #
14096: # CDGNM (CONTINUED)
14097: #
14098: # HERE TO EXIT GENERATING WORD (NON-CONSTANT)
14099: #
14100: cgn07: movl sp,r8 # set result non-constant
14101: jsb cdwrd # generate word
14102: jmp cgn03 # back to exit
14103: #
14104: # HERE TO GENERATE CODE FOR FUNCTIONS AND UNDEFINED OPRS
14105: #
14106: cgn08: movl r10,r9 # copy cmblk pointer
14107: jsb cdgvl # gen code by value for call
14108: movl $ofne$,r6 # get extra call for by name
14109: jmp cgn07 # back to generate and exit
14110: #
14111: # HERE TO GENERATE CODE FOR DEFERED EXPRESSION
14112: #
14113: cgn09: movl 4*cmrop(r10),r9 # check if variable
14114: cmpl (r9),$b$vr$ # treat *variable as simple var
14115: blssu 0f
14116: jmp cgn02
14117: 0:
14118: movl r9,r10 # copy ptr to expression tree
14119: jsb cdgex # else build exblk
14120: movl $olex$,r6 # set call to load expr by name
14121: jsb cdwrd # generate it
14122: movl r9,r6 # copy exblk pointer
14123: jsb cdwrd # generate exblk pointer
14124: jmp cgn03 # back to exit
14125: #
14126: # HERE TO GENERATE CODE FOR INDIRECT REFERENCE
14127: #
14128: cgn10: movl 4*cmrop(r10),r9 # get operand
14129: jsb cdgvl # generate code by value for it
14130: movl $oinn$,r6 # load call for indirect by name
14131: jmp cgn12 # merge
14132: #
14133: # HERE TO GENERATE CODE FOR KEYWORD REFERENCE
14134: #
14135: cgn11: movl 4*cmrop(r10),r9 # get operand
14136: jsb cdgnm # generate code by name for it
14137: movl $okwn$,r6 # load call for keyword by name
14138: #
14139: # KEYWORD, INDIRECT MERGE HERE
14140: #
14141: cgn12: jsb cdwrd # generate code for operator
14142: jmp cgn03 # exit
14143: #enp # end procedure cdgnm
14144: #page
14145: #
14146: # CDGVL -- GENERATE CODE BY VALUE
14147: #
14148: # CDGVL IS CALLED DURING THE COMPILATION PROCESS TO
14149: # GENERATE CODE BY VALUE FOR AN EXPRESSION. SEE CDBLK
14150: # DESCRIPTION FOR DETAILS OF THE CODE GENERATED. THE INPUT
14151: # TO CDGVL IS AN EXPRESSION TREE AS GENERATED BY EXPAN.
14152: #
14153: # CDGVL IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING
14154: # RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS.
14155: #
14156: # (WB) INTEGER IN RANGE 0 LE N LE DNAMB
14157: # (XR) PTR TO TREE GENERATED BY EXPAN
14158: # (WC) CONSTANT FLAG (SEE BELOW)
14159: # JSR CDGVL CALL TO GENERATE CODE BY VALUE
14160: # (XR,WA) DESTROYED
14161: # (WC) SET NON-ZERO IF NON-CONSTANT
14162: #
14163: # WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE
14164: # EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE
14165: # EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED.
14166: #
14167: # IF WC IS NON-ZERO ON ENTRY, THEN PREEVALUATION IS NOT
14168: # ALLOWED REGARDLESS OF THE NATURE OF THE OPERAND.
14169: #
14170: # THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD).
14171: #
14172: cdgvl: #prc # entry point, recursive
14173: movl (r9),r6 # load type word
14174: cmpl r6,$b$cmt # jump if cmblk
14175: beqlu cgv01
14176: cmpl r6,$b$vra # jump if icblk, rcblk, scblk
14177: blssu cgv00
14178: tstl 4*vrlen(r9) # jump if not system variable
14179: bnequ cgvl0
14180: movl r9,-(sp) # stack xr
14181: movl 4*vrsvp(r9),r9 # point to svblk
14182: movl 4*svbit(r9),r6 # get svblk property bits
14183: movl (sp)+,r9 # recover xr
14184: mcoml btckw,r11 # check if constant keyword
14185: bicl2 r11,r6
14186: tstl r6 # jump if constant keyword
14187: bnequ cgv00
14188: #
14189: # HERE FOR VARIABLE VALUE REFERENCE
14190: #
14191: cgvl0: movl sp,r8 # indicate non-constant value
14192: #
14193: # MERGE HERE FOR SIMPLE CONSTANT (ICBLK,RCBLK,SCBLK)
14194: # AND FOR VARIABLES CORRESPONDING TO CONSTANT KEYWORDS.
14195: #
14196: cgv00: movl r9,r6 # copy ptr to var or constant
14197: jsb cdwrd # generate as code word
14198: rsb # return to caller
14199: #page
14200: #
14201: # CDGVL (CONTINUED)
14202: #
14203: # HERE FOR TREE NODE (CMBLK)
14204: #
14205: cgv01: movl r7,-(sp) # save entry wb
14206: movl r10,-(sp) # save entry xl
14207: movl r8,-(sp) # save entry constant flag
14208: movl cwcof,-(sp) # save initial code offset
14209: jsb sbchk # check for stack overflow
14210: #
14211: # PREPARE TO GENERATE CODE FOR CMBLK. WC IS SET TO THE
14212: # VALUE OF CSWNO (ZERO IF -OPTIMISE, 1 IF -NOOPT) TO
14213: # START WITH AND IS RESET NON-ZERO FOR ANY NON-CONSTANT
14214: # CODE GENERATED. IF IT IS STILL ZERO AFTER GENERATING ALL
14215: # THE CMBLK CODE, THEN ITS VALUE IS COMPUTED AS THE RESULT.
14216: #
14217: movl r9,r10 # copy cmblk pointer
14218: movl 4*cmtyp(r9),r9 # load cmblk type
14219: movl cswno,r8 # reset constant flag
14220: cmpl r9,$c$pr$ # jump if not predicate value
14221: blequ cgv02
14222: movl sp,r8 # else force non-constant case
14223: #
14224: # HERE WITH WC SET APPROPRIATELY
14225: #
14226: cgv02: casel r9,$0,$c$$nv # switch to appropriate generator
14227: 5:
14228: .word cgv03-5b # array reference
14229: .word cgv05-5b # function call
14230: .word cgv14-5b # deferred expression
14231: .word cgv31-5b # indirect reference
14232: .word cgv27-5b # keyword reference
14233: .word cgv29-5b # undefined binop
14234: .word cgv30-5b # undefined unop
14235: .word cgv18-5b # binops with val opds
14236: .word cgv19-5b # unops with valu opnd
14237: .word cgv18-5b # alternation
14238: .word cgv24-5b # concatenation
14239: .word cgv24-5b # concatenation (not pattern match)
14240: .word cgv27-5b # unops with name opnd
14241: .word cgv26-5b # binary $ and .
14242: .word cgv21-5b # assignment
14243: .word cgv31-5b # interrogation
14244: .word cgv28-5b # negation
14245: .word cgv15-5b # selection
14246: .word cgv18-5b # pattern match
14247: #esw # end switch on cmblk type
14248: #page
14249: #
14250: # CDGVL (CONTINUED)
14251: #
14252: # HERE TO GENERATE CODE FOR ARRAY REFERENCE
14253: #
14254: cgv03: movl $4*cmopn,r7 # set offset to array operand
14255: #
14256: # LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
14257: #
14258: cgv04: jsb cmgen # gen value code for next operand
14259: movl 4*cmlen(r10),r8 # load cmblk length
14260: cmpl r7,r8 # loop back if more to go
14261: blssu cgv04
14262: #
14263: # GENERATE CALL TO APPROPRIATE ARRAY REFERENCE ROUTINE
14264: #
14265: movl $oaov$,r6 # set one subscript call in case
14266: cmpl r8,$4*cmar1 # jump to exit if 1-sub case
14267: bnequ 0f
14268: jmp cgv32
14269: 0:
14270: movl $oamv$,r6 # else set call for multi-subscripts
14271: jsb cdwrd # generate call
14272: movl r8,r6 # copy length of cmblk
14273: subl2 $4*cmvls,r6 # subtract standard length
14274: ashl $-2,r6,r6 # get number of words
14275: jmp cgv32 # jump to generate subscript count
14276: #
14277: # HERE TO GENERATE CODE FOR FUNCTION CALL
14278: #
14279: cgv05: movl $4*cmvls,r7 # set offset to first argument
14280: #
14281: # LOOP TO GENERATE CODE FOR ARGUMENTS
14282: #
14283: cgv06: cmpl r7,4*cmlen(r10) # jump if all generated
14284: beqlu cgv07
14285: jsb cmgen # else gen value code for next arg
14286: jmp cgv06 # back to generate next argument
14287: #
14288: # HERE TO GENERATE ACTUAL FUNCTION CALL
14289: #
14290: cgv07: subl2 $4*cmvls,r7 # get number of arg ptrs (bytes)
14291: ashl $-2,r7,r7 # convert bytes to words
14292: movl 4*cmopn(r10),r9 # load function vrblk pointer
14293: tstl 4*vrlen(r9) # jump if not system function
14294: bnequ cgv12
14295: movl 4*vrsvp(r9),r10 # load svblk ptr if system var
14296: movl 4*svbit(r10),r6 # load bit mask
14297: mcoml btffc,r11 # test for fast function call allowed
14298: bicl2 r11,r6
14299: tstl r6 # jump if not
14300: beqlu cgv12
14301: #page
14302: #
14303: # CDGVL (CONTINUED)
14304: #
14305: # HERE IF FAST FUNCTION CALL IS ALLOWED
14306: #
14307: movl 4*svbit(r10),r6 # reload bit indicators
14308: mcoml btpre,r11 # test for preevaluation ok
14309: bicl2 r11,r6
14310: tstl r6 # jump if preevaluation permitted
14311: bnequ cgv08
14312: movl sp,r8 # else set result non-constant
14313: #
14314: # TEST FOR CORRECT NUMBER OF ARGS FOR FAST CALL
14315: #
14316: cgv08: movl 4*vrfnc(r9),r10 # load ptr to svfnc field
14317: movl 4*fargs(r10),r6 # load svnar field value
14318: cmpl r6,r7 # jump if argument count is correct
14319: beqlu cgv11
14320: cmpl r6,r7 # jump if too few arguments given
14321: bgequ cgv09
14322: #
14323: # HERE IF TOO MANY ARGUMENTS, PREPARE TO GENERATE O$POPS
14324: #
14325: subl2 r6,r7 # get number of extra args
14326: # set as count to control loop
14327: movl $opop$,r6 # set pop call
14328: jmp cgv10 # jump to common loop
14329: #
14330: # HERE IF TOO FEW ARGUMENTS, PREPARE TO GENERATE NULLS
14331: #
14332: cgv09: subl2 r7,r6 # get number of missing arguments
14333: movl r6,r7 # load as count to control loop
14334: movl $nulls,r6 # load ptr to null constant
14335: #
14336: # LOOP TO GENERATE CALLS TO FIX ARGUMENT COUNT
14337: #
14338: cgv10: jsb cdwrd # generate one call
14339: sobgtr r7,cgv10 # loop till all generated
14340: #
14341: # HERE AFTER ADJUSTING ARG COUNT AS REQUIRED
14342: #
14343: cgv11: movl r10,r6 # copy pointer to svfnc field
14344: jmp cgv36 # jump to generate call
14345: #page
14346: #
14347: # CDGVL (CONTINUED)
14348: #
14349: # COME HERE IF FAST CALL IS NOT PERMITTED
14350: #
14351: cgv12: movl $ofns$,r6 # set one arg call in case
14352: cmpl r7,$num01 # jump if one arg case
14353: beqlu cgv13
14354: movl $ofnc$,r6 # else load call for more than 1 arg
14355: jsb cdwrd # generate it
14356: movl r7,r6 # copy argument count
14357: #
14358: # ONE ARG CASE MERGES HERE
14359: #
14360: cgv13: jsb cdwrd # generate =o$fns or arg count
14361: movl r9,r6 # copy vrblk pointer
14362: jmp cgv32 # jump to generate vrblk ptr
14363: #
14364: # HERE FOR DEFERRED EXPRESSION
14365: #
14366: cgv14: movl 4*cmrop(r10),r10# point to expression tree
14367: jsb cdgex # build exblk or seblk
14368: movl r9,r6 # copy block ptr
14369: jsb cdwrd # generate ptr to exblk or seblk
14370: jmp cgv34 # jump to exit, constant test
14371: #
14372: # HERE TO GENERATE CODE FOR SELECTION
14373: #
14374: cgv15: clrl -(sp) # zero ptr to chain of forward jumps
14375: clrl -(sp) # zero ptr to prev o$slc forward ptr
14376: movl $4*cmvls,r7 # point to first alternative
14377: movl $osla$,r6 # set initial code word
14378: #
14379: # 0(XS) IS THE OFFSET TO THE PREVIOUS WORD
14380: # WHICH REQUIRES FILLING IN WITH AN
14381: # OFFSET TO THE FOLLOWING O$SLC,O$SLD
14382: #
14383: # 1(XS) IS THE HEAD OF A CHAIN OF OFFSET
14384: # POINTERS INDICATING THOSE LOCATIONS
14385: # TO BE FILLED WITH OFFSETS PAST
14386: # THE END OF ALL THE ALTERNATIVES
14387: #
14388: cgv16: jsb cdwrd # generate o$slc (o$sla first time)
14389: movl cwcof,(sp) # set current loc as ptr to fill in
14390: jsb cdwrd # generate garbage word there for now
14391: jsb cmgen # gen value code for alternative
14392: movl $oslb$,r6 # load o$slb pointer
14393: jsb cdwrd # generate o$slb call
14394: movl 4*1(sp),r6 # load old chain ptr
14395: movl cwcof,4*1(sp) # set current loc as new chain head
14396: jsb cdwrd # generate forward chain link
14397: #page
14398: #
14399: # CDGVL (CONTINUED)
14400: #
14401: # NOW TO FILL IN THE SKIP OFFSET TO O$SLC,O$SLD
14402: #
14403: movl (sp),r9 # load offset to word to plug
14404: addl2 r$ccb,r9 # point to actual location to plug
14405: movl cwcof,(r9) # plug proper offset in
14406: movl $oslc$,r6 # load o$slc ptr for next alternative
14407: movl r7,r9 # copy offset (destroy garbage xr)
14408: addl2 $4,r9 # bump extra time for test
14409: cmpl r9,4*cmlen(r10) # loop back if not last alternative
14410: blssu cgv16
14411: #
14412: # HERE TO GENERATE CODE FOR LAST ALTERNATIVE
14413: #
14414: movl $osld$,r6 # get header call
14415: jsb cdwrd # generate o$sld call
14416: jsb cmgen # generate code for last alternative
14417: addl2 $4,sp # pop offset ptr
14418: movl (sp)+,r9 # load chain ptr
14419: #
14420: # LOOP TO PLUG OFFSETS PAST STRUCTURE
14421: #
14422: cgv17: addl2 r$ccb,r9 # make next ptr absolute
14423: movl (r9),r6 # load forward ptr
14424: movl cwcof,(r9) # plug required offset
14425: movl r6,r9 # copy forward ptr
14426: tstl r6 # loop back if more to go
14427: bnequ cgv17
14428: jmp cgv33 # else jump to exit (not constant)
14429: #
14430: # HERE FOR BINARY OPS WITH VALUE OPERANDS
14431: #
14432: cgv18: movl 4*cmlop(r10),r9 # load left operand pointer
14433: jsb cdgvl # gen value code for left operand
14434: #
14435: # HERE FOR UNARY OPS WITH VALUE OPERAND (BINOPS MERGE)
14436: #
14437: cgv19: movl 4*cmrop(r10),r9 # load right (only) operand ptr
14438: jsb cdgvl # gen code by value
14439: #page
14440: #
14441: # CDGVL (CONTINUED)
14442: #
14443: # MERGE HERE TO GENERATE OPERATOR CALL FROM CMOPN FIELD
14444: #
14445: cgv20: movl 4*cmopn(r10),r6 # load operator call pointer
14446: jmp cgv36 # jump to generate it with cons test
14447: #
14448: # HERE FOR ASSIGNMENT
14449: #
14450: cgv21: movl 4*cmlop(r10),r9 # load left operand pointer
14451: cmpl (r9),$b$vr$ # jump if not variable
14452: blequ cgv22
14453: #
14454: # HERE FOR ASSIGNMENT TO SIMPLE VARIABLE
14455: #
14456: movl 4*cmrop(r10),r9 # load right operand ptr
14457: jsb cdgvl # generate code by value
14458: movl 4*cmlop(r10),r6 # reload left operand vrblk ptr
14459: addl2 $4*vrsto,r6 # point to vrsto field
14460: jmp cgv32 # jump to generate store ptr
14461: #
14462: # HERE IF NOT SIMPLE VARIABLE ASSIGNMENT
14463: #
14464: cgv22: jsb expap # test for pattern match on left side
14465: .long cgv23 # jump if not pattern match
14466: #
14467: # HERE FOR PATTERN REPLACEMENT
14468: #
14469: movl 4*cmrop(r9),4*cmlop(r10) # save pattern ptr in safe place
14470: movl 4*cmlop(r9),r9 # load subject ptr
14471: jsb cdgnm # gen code by name for subject
14472: movl 4*cmlop(r10),r9 # load pattern ptr
14473: jsb cdgvl # gen code by value for pattern
14474: movl $opmn$,r6 # load match by name call
14475: jsb cdwrd # generate it
14476: movl 4*cmrop(r10),r9 # load replacement value ptr
14477: jsb cdgvl # gen code by value
14478: movl $orpl$,r6 # load replace call
14479: jmp cgv32 # jump to gen and exit (not constant)
14480: #
14481: # HERE FOR ASSIGNMENT TO COMPLEX VARIABLE
14482: #
14483: cgv23: movl sp,r8 # inhibit pre-evaluation
14484: jsb cdgnm # gen code by name for left side
14485: jmp cgv31 # merge with unop circuit
14486: #page
14487: #
14488: # CDGVL (CONTINUED)
14489: #
14490: # HERE FOR CONCATENATION
14491: #
14492: cgv24: movl 4*cmlop(r10),r9 # load left operand ptr
14493: cmpl (r9),$b$cmt # ordinary binop if not cmblk
14494: beqlu 0f
14495: jmp cgv18
14496: 0:
14497: movl 4*cmtyp(r9),r7 # load cmblk type code
14498: cmpl r7,$c$int # special case if interrogation
14499: beqlu cgv25
14500: cmpl r7,$c$neg # or negation
14501: beqlu cgv25
14502: cmpl r7,$c$fnc # else ordinary binop if not function
14503: beqlu 0f
14504: jmp cgv18
14505: 0:
14506: movl 4*cmopn(r9),r9 # else load function vrblk ptr
14507: tstl 4*vrlen(r9) # ordinary binop if not system var
14508: beqlu 0f
14509: jmp cgv18
14510: 0:
14511: movl 4*vrsvp(r9),r9 # else point to svblk
14512: movl 4*svbit(r9),r6 # load bit indicators
14513: mcoml btprd,r11 # test for predicate function
14514: bicl2 r11,r6
14515: tstl r6 # ordinary binop if not
14516: bnequ 0f
14517: jmp cgv18
14518: 0:
14519: #
14520: # HERE IF LEFT ARG OF CONCATENATION IS PREDICATE FUNCTION
14521: #
14522: cgv25: movl 4*cmlop(r10),r9 # reload left arg
14523: jsb cdgvl # gen code by value
14524: movl $opop$,r6 # load pop call
14525: jsb cdwrd # generate it
14526: movl 4*cmrop(r10),r9 # load right operand
14527: jsb cdgvl # gen code by value as result code
14528: jmp cgv33 # exit (not constant)
14529: #
14530: # HERE TO GENERATE CODE FOR PATTERN, IMMEDIATE ASSIGNMENT
14531: #
14532: cgv26: movl 4*cmlop(r10),r9 # load left operand
14533: jsb cdgvl # gen code by value, merge
14534: #
14535: # HERE FOR UNOPS WITH ARG BY NAME (BINARY $ . MERGE)
14536: #
14537: cgv27: movl 4*cmrop(r10),r9 # load right operand ptr
14538: jsb cdgnm # gen code by name for right arg
14539: movl 4*cmopn(r10),r9 # get operator code word
14540: cmpl (r9),$o$kwv # gen call unless keyword value
14541: beqlu 0f
14542: jmp cgv20
14543: 0:
14544: #page
14545: #
14546: # CDGVL (CONTINUED)
14547: #
14548: # HERE FOR KEYWORD BY VALUE. THIS IS CONSTANT ONLY IF
14549: # THE OPERAND IS ONE OF THE SPECIAL SYSTEM VARIABLES WITH
14550: # THE SVCKW BIT SET TO INDICATE A CONSTANT KEYWORD VALUE.
14551: # NOTE THAT THE ONLY CONSTANT OPERAND BY NAME IS A VARIABLE
14552: #
14553: tstl r8 # gen call if non-constant (not var)
14554: beqlu 0f
14555: jmp cgv20
14556: 0:
14557: movl sp,r8 # else set non-constant in case
14558: movl 4*cmrop(r10),r9 # load ptr to operand vrblk
14559: tstl 4*vrlen(r9) # gen (non-constant) if not sys var
14560: beqlu 0f
14561: jmp cgv20
14562: 0:
14563: movl 4*vrsvp(r9),r9 # else load ptr to svblk
14564: movl 4*svbit(r9),r6 # load bit mask
14565: mcoml btckw,r11 # test for constant keyword
14566: bicl2 r11,r6
14567: tstl r6 # go gen if not constant
14568: bnequ 0f
14569: jmp cgv20
14570: 0:
14571: clrl r8 # else set result constant
14572: jmp cgv20 # and jump back to generate call
14573: #
14574: # HERE TO GENERATE CODE FOR NEGATION
14575: #
14576: cgv28: movl $onta$,r6 # get initial word
14577: jsb cdwrd # generate it
14578: movl cwcof,r7 # save next offset
14579: jsb cdwrd # generate gunk word for now
14580: movl 4*cmrop(r10),r9 # load right operand ptr
14581: jsb cdgvl # gen code by value
14582: movl $ontb$,r6 # load end of evaluation call
14583: jsb cdwrd # generate it
14584: movl r7,r9 # copy offset to word to plug
14585: addl2 r$ccb,r9 # point to actual word to plug
14586: movl cwcof,(r9) # plug word with current offset
14587: movl $ontc$,r6 # load final call
14588: jmp cgv32 # jump to generate it (not constant)
14589: #
14590: # HERE TO GENERATE CODE FOR UNDEFINED BINARY OPERATOR
14591: #
14592: cgv29: movl 4*cmlop(r10),r9 # load left operand ptr
14593: jsb cdgvl # generate code by value
14594: #page
14595: #
14596: # CDGVL (CONTINUED)
14597: #
14598: # HERE TO GENERATE CODE FOR UNDEFINED UNARY OPERATOR
14599: #
14600: cgv30: movl $c$uo$,r7 # set unop code + 1
14601: subl2 4*cmtyp(r10),r7 # set number of args (1 or 2)
14602: #
14603: # MERGE HERE FOR UNDEFINED OPERATORS
14604: #
14605: movl 4*cmrop(r10),r9 # load right (only) operand pointer
14606: jsb cdgvl # gen value code for right operand
14607: movl 4*cmopn(r10),r9 # load pointer to operator dv
14608: movl 4*dvopn(r9),r9 # load pointer offset
14609: moval 0[r9],r9 # convert word offset to bytes
14610: addl2 $r$uba,r9 # point to proper function ptr
14611: subl2 $4*vrfnc,r9 # set standard function offset
14612: jmp cgv12 # merge with function call circuit
14613: #
14614: # HERE TO GENERATE CODE FOR INTERROGATION, INDIRECTION
14615: #
14616: cgv31: movl sp,r8 # set non constant
14617: jmp cgv19 # merge
14618: #
14619: # HERE TO EXIT GENERATING A WORD, RESULT NOT CONSTANT
14620: #
14621: cgv32: jsb cdwrd # generate word, merge
14622: #
14623: # HERE TO EXIT WITH NO WORD GENERATED, NOT CONSTANT
14624: #
14625: cgv33: movl sp,r8 # indicate result is not constant
14626: #
14627: # COMMON EXIT POINT
14628: #
14629: cgv34: addl2 $4,sp # pop initial code offset
14630: movl (sp)+,r6 # restore old constant flag
14631: movl (sp)+,r10 # restore entry xl
14632: movl (sp)+,r7 # restore entry wb
14633: tstl r8 # jump if not constant
14634: bnequ cgv35
14635: movl r6,r8 # else restore entry constant flag
14636: #
14637: # HERE TO RETURN AFTER DEALING WITH WC SETTING
14638: #
14639: cgv35: rsb # return to cdgvl caller
14640: #
14641: # EXIT HERE TO GENERATE WORD AND TEST FOR CONSTANT
14642: #
14643: cgv36: jsb cdwrd # generate word
14644: tstl r8 # jump to exit if not constant
14645: bnequ cgv34
14646: #page
14647: #
14648: # CDGVL (CONTINUED)
14649: #
14650: # HERE TO PREEVALUATE CONSTANT SUB-EXPRESSION
14651: #
14652: movl $orvl$,r6 # load call to return value
14653: jsb cdwrd # generate it
14654: movl (sp),r10 # load initial code offset
14655: jsb exbld # build exblk for expression
14656: clrl r7 # set to evaluate by value
14657: jsb evalx # evaluate expression
14658: .long invalid$ # should not fail
14659: movl (r9),r6 # load type word of result
14660: cmpl r6,$p$aaa # jump if not pattern
14661: blequ cgv37
14662: movl $olpt$,r6 # else load special pattern load call
14663: jsb cdwrd # generate it
14664: #
14665: # MERGE HERE TO GENERATE POINTER TO RESULTING CONSTANT
14666: #
14667: cgv37: movl r9,r6 # copy constant pointer
14668: jsb cdwrd # generate ptr
14669: clrl r8 # set result constant
14670: jmp cgv34 # jump back to exit
14671: #enp # end procedure cdgvl
14672: #page
14673: #
14674: # CDWRD -- GENERATE ONE WORD OF CODE
14675: #
14676: # CDWRD WRITES ONE WORD INTO THE CURRENT CODE BLOCK UNDER
14677: # CONSTRUCTION. A NEW, LARGER, BLOCK IS ALLOCATED IF THERE
14678: # IS INSUFFICIENT ROOM IN THE CURRENT BLOCK. CDWRD ENSURES
14679: # THAT THERE ARE AT LEAST THREE WORDS LEFT IN THE BLOCK
14680: # AFTER ENTERING THE NEW WORD. THIS GUARANTEES THAT ANY
14681: # EXTRA SPACE AT THE END CAN BE SPLIT OFF AS A CCBLK.
14682: #
14683: # (WA) WORD TO BE GENERATED
14684: # JSR CDWRD CALL TO GENERATE WORD
14685: #
14686: cdwrd: #prc # entry point
14687: movl r9,-(sp) # save entry xr
14688: movl r6,-(sp) # save code word to be generated
14689: #
14690: # MERGE BACK HERE AFTER ALLOCATING LARGER BLOCK
14691: #
14692: cdwd1: movl r$ccb,r9 # load ptr to ccblk being built
14693: tstl r9 # jump if block allocated
14694: bnequ cdwd2
14695: #
14696: # HERE WE ALLOCATE AN ENTIRELY FRESH BLOCK
14697: #
14698: movl $4*e$cbs,r6 # load initial length
14699: jsb alloc # allocate ccblk
14700: movl $b$cct,(r9) # store type word
14701: movl $4*cccod,cwcof # set initial offset
14702: movl r6,4*cclen(r9) # store block length
14703: movl r9,r$ccb # store ptr to new block
14704: #
14705: # HERE WE HAVE A BLOCK WE CAN USE
14706: #
14707: cdwd2: movl cwcof,r6 # load current offset
14708: addl2 $4*num04,r6 # adjust for test (four words)
14709: cmpl r6,4*cclen(r9) # jump if room in this block
14710: bgtru 0f
14711: jmp cdwd4
14712: 0:
14713: #
14714: # HERE IF NO ROOM IN CURRENT BLOCK
14715: #
14716: cmpl r6,mxlen # jump if already at max size
14717: blssu 0f
14718: jmp cdwd5
14719: 0:
14720: addl2 $4*e$cbs,r6 # else get new size
14721: movl r10,-(sp) # save entry xl
14722: movl r9,r10 # copy pointer
14723: cmpl r6,mxlen # jump if not too large
14724: blssu cdwd3
14725: movl mxlen,r6 # else reset to max allowed size
14726: #page
14727: #
14728: # CDWRD (CONTINUED)
14729: #
14730: # HERE WITH NEW BLOCK SIZE IN WA
14731: #
14732: cdwd3: jsb alloc # allocate new block
14733: movl r9,r$ccb # store pointer to new block
14734: movl $b$cct,(r9)+ # store type word in new block
14735: movl r6,(r9)+ # store block length
14736: addl2 $4*ccuse,r10 # point to ccuse,cccod fields in old
14737: movl (r10),r6 # load ccuse value
14738: jsb sbmvw # copy useful words from old block
14739: movl (sp)+,r10 # restore xl
14740: jmp cdwd1 # merge back to try again
14741: #
14742: # HERE WITH ROOM IN CURRENT BLOCK
14743: #
14744: cdwd4: movl cwcof,r6 # load current offset
14745: addl2 $4,r6 # get new offset
14746: movl r6,cwcof # store new offset
14747: movl r6,4*ccuse(r9) # store in ccblk for gbcol
14748: subl2 $4,r6 # restore ptr to this word
14749: addl2 r6,r9 # point to current entry
14750: movl (sp)+,r6 # reload word to generate
14751: movl r6,(r9) # store word in block
14752: movl (sp)+,r9 # restore entry xr
14753: rsb # return to caller
14754: #
14755: # HERE IF COMPILED CODE IS TOO LONG FOR CDBLK
14756: #
14757: cdwd5: jmp er_213 # syntax error. statement is too complicated.
14758: #enp # end procedure cdwrd
14759: #page
14760: #
14761: # CMGEN -- GENERATE CODE FOR CMBLK PTR
14762: #
14763: # CMGEN IS A SUBSIDIARY PROCEDURE USED TO GENERATE VALUE
14764: # CODE FOR A CMBLK PTR FROM THE MAIN CODE GENERATORS.
14765: #
14766: # (XL) CMBLK POINTER
14767: # (WB) OFFSET TO POINTER IN CMBLK
14768: # JSR CMGEN CALL TO GENERATE CODE
14769: # (XR,WA) DESTROYED
14770: # (WB) BUMPED BY ONE WORD
14771: #
14772: cmgen: #prc # entry point, recursive
14773: movl r10,r9 # copy cmblk pointer
14774: addl2 r7,r9 # point to cmblk pointer
14775: movl (r9),r9 # load cmblk pointer
14776: jsb cdgvl # generate code by value
14777: addl2 $4,r7 # bump offset
14778: rsb # return to caller
14779: #enp # end procedure cmgen
14780: #page
14781: #
14782: # CMPIL (COMPILE SOURCE CODE)
14783: #
14784: # CMPIL IS USED TO CONVERT SNOBOL4 SOURCE CODE TO INTERNAL
14785: # FORM (SEE CDBLK FORMAT). IT IS USED BOTH FOR THE INITIAL
14786: # COMPILE AND AT RUN TIME BY THE CODE AND CONVERT FUNCTIONS
14787: # THIS PROCEDURE HAS CONTROL FOR THE ENTIRE DURATION OF
14788: # INITIAL COMPILATION. AN ERROR IN ANY PROCEDURE CALLED
14789: # DURING COMPILATION WILL LEAD FIRST TO THE ERROR SECTION
14790: # AND ULTIMATELY BACK HERE FOR RESUMED COMPILATION. THE
14791: # RE-ENTRY POINTS AFTER AN ERROR ARE SPECIALLY LABELLED -
14792: #
14793: # CMPCE RESUME AFTER CONTROL CARD ERROR
14794: # CMPLE RESUME AFTER LABEL ERROR
14795: # CMPSE RESUME AFTER STATEMENT ERROR
14796: #
14797: # JSR CMPIL CALL TO COMPILE CODE
14798: # (XR) PTR TO CDBLK FOR ENTRY STATEMENT
14799: # (XL,WA,WB,WC,RA) DESTROYED
14800: #
14801: # THE FOLLOWING GLOBAL VARIABLES ARE REFERENCED
14802: #
14803: # CMPSN NUMBER OF NEXT STATEMENT
14804: # TO BE COMPILED.
14805: #
14806: # CSWXX CONTROL CARD SWITCH VALUES ARE
14807: # CHANGED WHEN RELEVANT CONTROL
14808: # CARDS ARE MET.
14809: #
14810: # CWCOF OFFSET TO NEXT WORD IN CODE BLOCK
14811: # BEING BUILT (SEE CDWRD).
14812: #
14813: # LSTSN NUMBER OF STATEMENT MOST RECENTLY
14814: # COMPILED (INITIALLY SET TO ZERO).
14815: #
14816: # R$CIM CURRENT (INITIAL) COMPILER IMAGE
14817: # (ZERO FOR INITIAL COMPILE CALL)
14818: #
14819: # R$CNI USED TO POINT TO FOLLOWING IMAGE.
14820: # (SEE READR PROCEDURE).
14821: #
14822: # SCNGO GOTO SWITCH FOR SCANE PROCEDURE
14823: #
14824: # SCNIL LENGTH OF CURRENT IMAGE EXCLUDING
14825: # CHARACTERS REMOVED BY -INPUT.
14826: #
14827: # SCNPT CURRENT SCAN OFFSET, SEE SCANE.
14828: #
14829: # SCNRS RESCAN SWITCH FOR SCANE PROCEDURE.
14830: #
14831: # SCNSE OFFSET (IN R$CIM) OF MOST RECENTLY
14832: # SCANNED ELEMENT. SET ZERO IF NOT
14833: # CURRENTLY SCANNING ITEMS
14834: #page
14835: #
14836: # CMPIL (CONTINUED)
14837: #
14838: # STAGE STGIC INITIAL COMPILE IN PROGRESS
14839: # STGXC CODE/CONVERT COMPILE
14840: # STGEV BUILDING EXBLK FOR EVAL
14841: # STGXT EXECUTE TIME (OUTSIDE COMPILE)
14842: # STGCE INITIAL COMPILE AFTER END LINE
14843: # STGXE EXECUTE COMPILE AFTER END LINE
14844: #
14845: # CMPIL ALSO USES A FIXED NUMBER OF LOCATIONS ON THE
14846: # MAIN STACK AS FOLLOWS. (THE DEFINITIONS OF THE ACTUAL
14847: # OFFSETS ARE IN THE DEFINITIONS SECTION).
14848: #
14849: # CMSTM(XS) POINTER TO EXPAN TREE FOR BODY OF
14850: # STATEMENT (SEE EXPAN PROCEDURE).
14851: #
14852: # CMSGO(XS) POINTER TO TREE REPRESENTATION OF
14853: # SUCCESS GOTO (SEE PROCEDURE SCNGO)9
14854: # ZERO IF NO SUCCESS GOTO IS GIVEN
14855: #
14856: # CMFGO(XS) LIKE CMSGO FOR FAILURE GOTO.
14857: #
14858: # CMCGO(XS) SET NON-ZERO ONLY IF THERE IS A
14859: # CONDITIONAL GOTO. USED FOR -FAIL,
14860: # -NOFAIL CODE GENERATION.
14861: #
14862: # CMPCD(XS) POINTER TO CDBLK FOR PREVIOUS
14863: # STATEMENT. ZERO FOR 1ST STATEMENT.
14864: #
14865: # CMFFP(XS) SET NON-ZERO IF CDFAL IN PREVIOUS
14866: # CDBLK NEEDS FILLING WITH FORWARD
14867: # POINTER, ELSE SET TO ZERO.
14868: #
14869: # CMFFC(XS) SAME AS CMFFP FOR CURRENT CDBLK
14870: #
14871: # CMSOP(XS) OFFSET TO WORD IN PREVIOUS CDBLK
14872: # TO BE FILLED IN WITH FORWARD PTR
14873: # TO NEXT CDBLK FOR SUCCESS GOTO.
14874: # ZERO IF NO FILL IN IS REQUIRED.
14875: #
14876: # CMSOC(XS) SAME AS CMSOP FOR CURRENT CDBLK.
14877: #
14878: # CMLBL(XS) POINTER TO VRBLK FOR LABEL OF
14879: # CURRENT STATEMENT. ZERO IF NO LABEL
14880: #
14881: # CMTRA(XS) POINTER TO CDBLK FOR ENTRY STMNT.
14882: #page
14883: #
14884: # CMPIL (CONTINUED)
14885: #
14886: # ENTRY POINT
14887: #
14888: cmpil: #prc # entry point
14889: movl $cmnen,r7 # set number of stack work locations
14890: #
14891: # LOOP TO INITIALIZE STACK WORKING LOCATIONS
14892: #
14893: cmp00: clrl -(sp) # store a zero, make one entry
14894: sobgtr r7,cmp00 # loop back until all set
14895: movl sp,cmpxs # save stack pointer for error sec
14896: #sss cmpss # save s-r stack pointer if any
14897: #
14898: # LOOP THROUGH STATEMENTS
14899: #
14900: cmp01: movl scnpt,r7 # set scan pointer offset
14901: movl r7,scnse # set start of element location
14902: movl $ocer$,r6 # point to compile error call
14903: jsb cdwrd # generate as temporary cdfal
14904: cmpl r7,scnil # jump if chars left on this image
14905: blssu cmp04
14906: #
14907: # LOOP HERE AFTER COMMENT OR CONTROL CARD
14908: # ALSO SPECIAL ENTRY AFTER CONTROL CARD ERROR
14909: #
14910: cmpce: clrl r9 # clear possible garbage xr value
14911: cmpl stage,$stgic # skip unless initial compile
14912: bnequ cmp02
14913: jsb readr # read next input image
14914: tstl r9 # jump if no input available
14915: bnequ 0f
14916: jmp cmp09
14917: 0:
14918: jsb nexts # acquire next source image
14919: movl cmpsn,lstsn # store stmt no for use by listr
14920: clrl scnpt # reset scan pointer
14921: jmp cmp04 # go process image
14922: #
14923: # FOR EXECUTE TIME COMPILE, PERMIT EMBEDDED CONTROL CARDS
14924: # AND COMMENTS (BY SKIPPING TO NEXT SEMI-COLON)
14925: #
14926: cmp02: movl r$cim,r9 # get current image
14927: movl scnpt,r7 # get current offset
14928: movab cfp$f(r9)[r7],r9# prepare to get chars
14929: #
14930: # SKIP TO SEMI-COLON
14931: #
14932: cmp03: movzbl (r9)+,r8 # get char
14933: incl scnpt # advance offset
14934: cmpl r8,$ch$sm # skip if semi-colon found
14935: beqlu cmp04
14936: cmpl scnpt,scnil # loop if more chars
14937: blssu cmp03
14938: clrl r9 # clear garbage xr value
14939: jmp cmp09 # end of image
14940: #page
14941: #
14942: # CMPIL (CONTINUED)
14943: #
14944: # HERE WITH IMAGE AVAILABLE TO SCAN. NOTE THAT IF THE INPUT
14945: # STRING IS NULL, THEN EVERYTHING IS OK SINCE NULL IS
14946: # ACTUALLY ASSEMBLED AS A WORD OF BLANKS.
14947: #
14948: cmp04: movl r$cim,r9 # point to current image
14949: movl scnpt,r7 # load current offset
14950: movl r7,r6 # copy for label scan
14951: movab cfp$f(r9)[r7],r9# point to first character
14952: movzbl (r9)+,r8 # load first character
14953: cmpl r8,$ch$sm # no label if semicolon
14954: bnequ 0f
14955: jmp cmp12
14956: 0:
14957: cmpl r8,$ch$as # loop back if comment card
14958: bnequ 0f
14959: jmp cmpce
14960: 0:
14961: cmpl r8,$ch$mn # jump if control card
14962: bnequ 0f
14963: jmp cmp32
14964: 0:
14965: movl r$cim,r$cmp # about to destroy r$cim
14966: movl $cmlab,r10 # point to label work string
14967: movl r10,r$cim # scane is to scan work string
14968: movab cfp$f(r10),r10 # point to first character position
14969: movb r8,(r10)+ # store char just loaded
14970: movl $ch$sm,r8 # get a semicolon
14971: movb r8,(r10) # store after first char
14972: #csc r10 # finished character storing
14973: clrl r10 # clear pointer
14974: clrl scnpt # start at first character
14975: movl scnil,-(sp) # preserve image length
14976: movl $num02,scnil # read 2 chars at most
14977: jsb scane # scan first char for type
14978: movl (sp)+,scnil # restore image length
14979: movl r10,r8 # note return code
14980: movl r$cmp,r10 # get old r$cim
14981: movl r10,r$cim # put it back
14982: movl r7,scnpt # reinstate offset
14983: tstl scnbl # blank seen - cant be label
14984: beqlu 0f
14985: jmp cmp12
14986: 0:
14987: movl r10,r9 # point to current image
14988: movab cfp$f(r9)[r7],r9# point to first char again
14989: cmpl r8,$t$var # ok if letter
14990: beqlu cmp06
14991: cmpl r8,$t$con # ok if digit
14992: beqlu cmp06
14993: #
14994: # DROP IN OR JUMP FROM ERROR SECTION IF SCANE FAILED
14995: #
14996: cmple: movl r$cmp,r$cim # point to bad line
14997: jmp er_214 # bad label or misplaced continuation line
14998: #
14999: # LOOP TO SCAN LABEL
15000: #
15001: cmp05: cmpl r8,$ch$sm # skip if semicolon
15002: beqlu cmp07
15003: incl r6 # bump offset
15004: cmpl r6,scnil # jump if end of image (label end)
15005: beqlu cmp07
15006: #page
15007: #
15008: # CMPIL (CONTINUED)
15009: #
15010: # ENTER LOOP AT THIS POINT
15011: #
15012: cmp06: movzbl (r9)+,r8 # else load next character
15013: cmpl r8,$ch$ht # jump if horizontal tab
15014: beqlu cmp07
15015: cmpl r8,$ch$bl # loop back if non-blank
15016: bnequ cmp05
15017: #
15018: # HERE AFTER SCANNING OUT LABEL
15019: #
15020: cmp07: movl r6,scnpt # save updated scan offset
15021: subl2 r7,r6 # get length of label
15022: tstl r6 # skip if label length zero
15023: bnequ 0f
15024: jmp cmp12
15025: 0:
15026: clrl r9 # clear garbage xr value
15027: jsb sbstr # build scblk for label name
15028: jsb gtnvr # locate/contruct vrblk
15029: .long invalid$ # dummy (impossible) error return
15030: movl r9,4*cmlbl(sp) # store label pointer
15031: tstl 4*vrlen(r9) # jump if not system label
15032: bnequ cmp11
15033: cmpl 4*vrsvp(r9),$v$end # jump if not end label
15034: bnequ cmp11
15035: #
15036: # HERE FOR END LABEL SCANNED OUT
15037: #
15038: addl2 $stgnd,stage # adjust stage appropriately
15039: jsb scane # scan out next element
15040: cmpl r10,$t$smc # jump if end of image
15041: bnequ 0f
15042: jmp cmp10
15043: 0:
15044: cmpl r10,$t$var # else error if not variable
15045: bnequ cmp08
15046: #
15047: # HERE CHECK FOR VALID INITIAL TRANSFER
15048: #
15049: cmpl 4*vrlbl(r9),$stndl # jump if not defined (error)
15050: beqlu cmp08
15051: movl 4*vrlbl(r9),4*cmtra(sp) # else set initial entry pointer
15052: jsb scane # scan next element
15053: cmpl r10,$t$smc # jump if ok (end of image)
15054: bnequ 0f
15055: jmp cmp10
15056: 0:
15057: #
15058: # HERE FOR BAD TRANSFER LABEL
15059: #
15060: cmp08: jmp er_215 # syntax error. undefined or erroneous entry label
15061: #
15062: # HERE FOR END OF INPUT (NO END LABEL DETECTED)
15063: #
15064: cmp09: addl2 $stgnd,stage # adjust stage appropriately
15065: cmpl stage,$stgxe # jump if code call (ok)
15066: bnequ 0f
15067: jmp cmp10
15068: 0:
15069: jmp er_216 # syntax error. missing end line
15070: #
15071: # HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR)
15072: #
15073: cmp10: movl $ostp$,r6 # set stop call pointer
15074: jsb cdwrd # generate as statement call
15075: jmp cmpse # jump to generate as failure
15076: #page
15077: #
15078: # CMPIL (CONTINUED)
15079: #
15080: # HERE AFTER PROCESSING LABEL OTHER THAN END
15081: #
15082: cmp11: cmpl stage,$stgic # jump if code call - redef. ok
15083: beqlu 0f
15084: jmp cmp12
15085: 0:
15086: cmpl 4*vrlbl(r9),$stndl # else check for redefinition
15087: bnequ 0f
15088: jmp cmp12
15089: 0:
15090: clrl 4*cmlbl(sp) # leave first label decln undisturbed
15091: jmp er_217 # syntax error. duplicate label
15092: #
15093: # HERE AFTER DEALING WITH LABEL
15094: #
15095: cmp12: clrl r7 # set flag for statement body
15096: jsb expan # get tree for statement body
15097: movl r9,4*cmstm(sp) # store for later use
15098: clrl 4*cmsgo(sp) # clear success goto pointer
15099: clrl 4*cmfgo(sp) # clear failure goto pointer
15100: clrl 4*cmcgo(sp) # clear conditional goto flag
15101: jsb scane # scan next element
15102: cmpl r10,$t$col # jump it not colon (no goto)
15103: beqlu 0f
15104: jmp cmp18
15105: 0:
15106: #
15107: # LOOP TO PROCESS GOTO FIELDS
15108: #
15109: cmp13: movl sp,scngo # set goto flag
15110: jsb scane # scan next element
15111: cmpl r10,$t$smc # jump if no fields left
15112: bnequ 0f
15113: jmp cmp31
15114: 0:
15115: cmpl r10,$t$sgo # jump if s for success goto
15116: beqlu cmp14
15117: cmpl r10,$t$fgo # jump if f for failure goto
15118: beqlu cmp16
15119: #
15120: # HERE FOR UNCONDITIONAL GOTO (I.E. NOT F OR S)
15121: #
15122: movl sp,scnrs # set to rescan element not f,s
15123: jsb scngf # scan out goto field
15124: tstl 4*cmfgo(sp) # error if fgoto already
15125: bnequ cmp17
15126: movl r9,4*cmfgo(sp) # else set as fgoto
15127: jmp cmp15 # merge with sgoto circuit
15128: #
15129: # HERE FOR SUCCESS GOTO
15130: #
15131: cmp14: jsb scngf # scan success goto field
15132: movl $num01,4*cmcgo(sp) # set conditional goto flag
15133: #
15134: # UNCONTIONAL GOTO MERGES HERE
15135: #
15136: cmp15: tstl 4*cmsgo(sp) # error if sgoto already given
15137: bnequ cmp17
15138: movl r9,4*cmsgo(sp) # else set sgoto
15139: jmp cmp13 # loop back for next goto field
15140: #
15141: # HERE FOR FAILURE GOTO
15142: #
15143: cmp16: jsb scngf # scan goto field
15144: movl $num01,4*cmcgo(sp) # set conditonal goto flag
15145: tstl 4*cmfgo(sp) # error if fgoto already given
15146: bnequ cmp17
15147: movl r9,4*cmfgo(sp) # else store fgoto pointer
15148: jmp cmp13 # loop back for next field
15149: #page
15150: #
15151: # CMPIL (CONTINUED)
15152: #
15153: # HERE FOR DUPLICATED GOTO FIELD
15154: #
15155: cmp17: jmp er_218 # syntax error. duplicated goto field
15156: #
15157: # HERE TO GENERATE CODE
15158: #
15159: cmp18: clrl scnse # stop positional error flags
15160: movl 4*cmstm(sp),r9 # load tree ptr for statement body
15161: clrl r7 # collectable value for wb for cdgvl
15162: clrl r8 # reset constant flag for cdgvl
15163: jsb expap # test for pattern match
15164: .long cmp19 # jump if not pattern match
15165: movl $opms$,4*cmopn(r9) # else set pattern match pointer
15166: movl $c$pmt,4*cmtyp(r9)
15167: #
15168: # HERE AFTER DEALING WITH SPECIAL PATTERN MATCH CASE
15169: #
15170: cmp19: jsb cdgvl # generate code for body of statement
15171: movl 4*cmsgo(sp),r9 # load sgoto pointer
15172: movl r9,r6 # copy it
15173: tstl r9 # jump if no success goto
15174: beqlu cmp21
15175: clrl 4*cmsoc(sp) # clear success offset fillin ptr
15176: cmpl r9,state # jump if complex goto
15177: bgequ cmp20
15178: #
15179: # HERE FOR SIMPLE SUCCESS GOTO (LABEL)
15180: #
15181: addl2 $4*vrtra,r6 # point to vrtra field as required
15182: jsb cdwrd # generate success goto
15183: jmp cmp22 # jump to deal with fgoto
15184: #
15185: # HERE FOR COMPLEX SUCCESS GOTO
15186: #
15187: cmp20: cmpl r9,4*cmfgo(sp) # no code if same as fgoto
15188: beqlu cmp22
15189: clrl r7 # else set ok value for cdgvl in wb
15190: jsb cdgcg # generate code for success goto
15191: jmp cmp22 # jump to deal with fgoto
15192: #
15193: # HERE FOR NO SUCCESS GOTO
15194: #
15195: cmp21: movl cwcof,4*cmsoc(sp)# set success fill in offset
15196: movl $ocer$,r6 # point to compile error call
15197: jsb cdwrd # generate as temporary value
15198: #page
15199: #
15200: # CMPIL (CONTINUED)
15201: #
15202: # HERE TO DEAL WITH FAILURE GOTO
15203: #
15204: cmp22: movl 4*cmfgo(sp),r9 # load failure goto pointer
15205: movl r9,r6 # copy it
15206: clrl 4*cmffc(sp) # set no fill in required yet
15207: tstl r9 # jump if no failure goto given
15208: beqlu cmp23
15209: addl2 $4*vrtra,r6 # point to vrtra field in case
15210: cmpl r9,state # jump to gen if simple fgoto
15211: blequ cmpse
15212: #
15213: # HERE FOR COMPLEX FAILURE GOTO
15214: #
15215: movl cwcof,r7 # save offset to o$gof call
15216: movl $ogof$,r6 # point to failure goto call
15217: jsb cdwrd # generate
15218: movl $ofif$,r6 # point to fail in fail word
15219: jsb cdwrd # generate
15220: jsb cdgcg # generate code for failure goto
15221: movl r7,r6 # copy offset to o$gof for cdfal
15222: movl $b$cdc,r7 # set complex case cdtyp
15223: jmp cmp25 # jump to build cdblk
15224: #
15225: # HERE IF NO FAILURE GOTO GIVEN
15226: #
15227: cmp23: movl $ounf$,r6 # load unexpected failure call in cas
15228: movl cswfl,r8 # get -nofail flag
15229: bisl2 4*cmcgo(sp),r8 # check if conditional goto
15230: tstl r8 # jump if -nofail and no cond. goto
15231: beqlu cmpse
15232: movl sp,4*cmffc(sp) # else set fill in flag
15233: movl $ocer$,r6 # and set compile error for temporary
15234: #
15235: # MERGE HERE WITH CDFAL VALUE IN WA, SIMPLE CDBLK
15236: # ALSO SPECIAL ENTRY AFTER STATEMENT ERROR
15237: #
15238: cmpse: movl $b$cds,r7 # set cdtyp for simple case
15239: #page
15240: #
15241: # CMPIL (CONTINUED)
15242: #
15243: # MERGE HERE TO BUILD CDBLK
15244: #
15245: # (WA) CDFAL VALUE TO BE GENERATED
15246: # (WB) CDTYP VALUE TO BE GENERATED
15247: #
15248: # AT THIS STAGE, WE CHOP OFF AN APPROPRIATE CHUNK OF THE
15249: # CURRENT CCBLK AND CONVERT IT INTO A CDBLK. THE REMAINDER
15250: # OF THE CCBLK IS REFORMATTED TO BE THE NEW CCBLK.
15251: #
15252: cmp25: movl r$ccb,r9 # point to ccblk
15253: movl 4*cmlbl(sp),r10 # get possible label pointer
15254: tstl r10 # skip if no label
15255: beqlu cmp26
15256: clrl 4*cmlbl(sp) # clear flag for next statement
15257: movl r9,4*vrlbl(r10) # put cdblk ptr in vrblk label field
15258: #
15259: # MERGE AFTER DOING LABEL
15260: #
15261: cmp26: movl r7,(r9) # set type word for new cdblk
15262: movl r6,4*cdfal(r9) # set failure word
15263: movl r9,r10 # copy pointer to ccblk
15264: movl 4*ccuse(r9),r7 # load length gen (= new cdlen)
15265: movl 4*cclen(r9),r8 # load total ccblk length
15266: addl2 r7,r10 # point past cdblk
15267: subl2 r7,r8 # get length left for chop off
15268: movl $b$cct,(r10) # set type code for new ccblk at end
15269: movl $4*cccod,4*ccuse(r10) # set initial code offset
15270: movl $4*cccod,cwcof # reinitialise cwcof
15271: movl r8,4*cclen(r10) # set new length
15272: movl r10,r$ccb # set new ccblk pointer
15273: movl cmpsn,4*cdstm(r9)# set statement number
15274: incl cmpsn # bump statement number
15275: #
15276: # SET POINTERS IN PREVIOUS CODE BLOCK AS REQUIRED
15277: #
15278: movl 4*cmpcd(sp),r10 # load ptr to previous cdblk
15279: tstl 4*cmffp(sp) # jump if no failure fill in required
15280: beqlu cmp27
15281: movl r9,4*cdfal(r10) # else set failure ptr in previous
15282: #
15283: # HERE TO DEAL WITH SUCCESS FORWARD POINTER
15284: #
15285: cmp27: movl 4*cmsop(sp),r6 # load success offset
15286: tstl r6 # jump if no fill in required
15287: beqlu cmp28
15288: addl2 r6,r10 # else point to fill in location
15289: movl r9,(r10) # store forward pointer
15290: clrl r10 # clear garbage xl value
15291: #page
15292: #
15293: # CMPIL (CONTINUED)
15294: #
15295: # NOW SET FILL IN POINTERS FOR THIS STATEMENT
15296: #
15297: cmp28: movl 4*cmffc(sp),4*cmffp(sp) # copy failure fill in flag
15298: movl 4*cmsoc(sp),4*cmsop(sp) # copy success fill in offset
15299: movl r9,4*cmpcd(sp) # save ptr to this cdblk
15300: tstl 4*cmtra(sp) # jump if initial entry already set
15301: bnequ cmp29
15302: movl r9,4*cmtra(sp) # else set ptr here as default
15303: #
15304: # HERE AFTER COMPILING ONE STATEMENT
15305: #
15306: cmp29: cmpl stage,$stgce # jump if not end line just done
15307: bgequ 0f
15308: jmp cmp01
15309: 0:
15310: tstl cswls # skip if -nolist
15311: beqlu cmp30
15312: jsb listr # list last line
15313: #
15314: # RETURN
15315: #
15316: cmp30: movl 4*cmtra(sp),r9 # load initial entry cdblk pointer
15317: addl2 $4*cmnen,sp # pop work locations off stack
15318: rsb # and return to cmpil caller
15319: #
15320: # HERE AT END OF GOTO FIELD
15321: #
15322: cmp31: movl 4*cmfgo(sp),r7 # get fail goto
15323: bisl2 4*cmsgo(sp),r7 # or in success goto
15324: tstl r7 # ok if non-null field
15325: beqlu 0f
15326: jmp cmp18
15327: 0:
15328: jmp er_219 # syntax error. empty goto field
15329: #
15330: # CONTROL CARD FOUND
15331: #
15332: cmp32: incl r7 # point past ch$mn
15333: jsb cncrd # process control card
15334: clrl scnse # clear start of element loc.
15335: jmp cmpce # loop for next statement
15336: #enp # end procedure cmpil
15337: #page
15338: #
15339: # CNCRD -- CONTROL CARD PROCESSOR
15340: #
15341: # CALLED TO DEAL WITH CONTROL CARDS
15342: #
15343: # R$CIM POINTS TO CURRENT IMAGE
15344: # (WB) OFFSET TO 1ST CHAR OF CONTROL CARD
15345: # JSR CNCRD CALL TO PROCESS CONTROL CARDS
15346: # (XL,XR,WA,WB,WC,IA) DESTROYED
15347: #
15348: cncrd: #prc # entry point
15349: movl r7,scnpt # offset for control card scan
15350: movl $ccnoc,r6 # number of chars for comparison
15351: movab 3+(4*0)(r6),r6 # convert to word count
15352: ashl $-2,r6,r6
15353: movl r6,cnswc # save word count
15354: #
15355: # LOOP HERE IF MORE THAN ONE CONTROL CARD
15356: #
15357: cnc01: cmpl scnpt,scnil # return if end of image
15358: blssu 0f
15359: jmp cnc09
15360: 0:
15361: movl r$cim,r9 # point to image
15362: movl scnpt,r11 # [get in scratch register]
15363: movab cfp$f(r9)[r11],r9# char ptr for first char
15364: movzbl (r9)+,r6 # get first char
15365: bicl2 $ch$bl,r6 # fold to upper case
15366: cmpl r6,$ch$li # special case of -inxxx
15367: bnequ 0f
15368: jmp cnc07
15369: 0:
15370: movl sp,scncc # set flag for scane
15371: jsb scane # scan card name
15372: clrl scncc # clear scane flag
15373: tstl r10 # fail unless control card name
15374: beqlu 0f
15375: jmp cnc06
15376: 0:
15377: movl $ccnoc,r6 # no. of chars to be compared
15378: cmpl 4*sclen(r9),r6 # fail if too few chars
15379: bgequ 0f
15380: jmp cnc06
15381: 0:
15382: movl r9,r10 # point to control card name
15383: clrl r7 # zero offset for substring
15384: jsb sbstr # extract substring for comparison
15385: movl 4*sclen(r9),r6 # reload length
15386: jsb flstg # fold to upper case
15387: movl r9,cnscc # keep control card substring ptr
15388: movl $ccnms,r9 # point to list of standard names
15389: clrl r7 # initialise name offset
15390: movl $cc$nc,r8 # number of standard names
15391: #
15392: # TRY TO MATCH NAME
15393: #
15394: cnc02: movl cnscc,r10 # point to name
15395: movl cnswc,r6 # counter for inner loop
15396: jmp cnc04 # jump into loop
15397: #
15398: # INNER LOOP TO MATCH CARD NAME CHARS
15399: #
15400: cnc03: addl2 $4,r9 # bump standard names ptr
15401: addl2 $4,r10 # bump name pointer
15402: #
15403: # HERE TO INITIATE THE LOOP
15404: #
15405: cnc04: cmpl 4*schar(r10),(r9)# comp. up to cfp$c chars at once
15406: bnequ cnc05
15407: sobgtr r6,cnc03 # loop if more words to compare
15408: #page
15409: #
15410: # CNCRD (CONTINUED)
15411: #
15412: # MATCHED - BRANCH ON CARD OFFSET
15413: #
15414: movl r7,r10 # get name offset
15415: casel r10,$0,$cc$nc # switch
15416: 5:
15417: .word cnc37-5b # -case
15418: .word cnc10-5b # -double
15419: .word cnc11-5b # -dump
15420: .word cnc12-5b # -eject
15421: .word cnc13-5b # -errors
15422: .word cnc14-5b # -execute
15423: .word cnc15-5b # -fail
15424: .word cnc16-5b # -list
15425: .word cnc17-5b # -noerrors
15426: .word cnc18-5b # -noexecute
15427: .word cnc19-5b # -nofail
15428: .word cnc20-5b # -nolist
15429: .word cnc21-5b # -noopt
15430: .word cnc22-5b # -noprint
15431: .word cnc24-5b # -optimise
15432: .word cnc25-5b # -print
15433: .word cnc27-5b # -single
15434: .word cnc28-5b # -space
15435: .word cnc31-5b # -stitle
15436: .word cnc32-5b # -title
15437: .word cnc36-5b # -trace
15438: #esw # end switch
15439: #
15440: # NOT MATCHED YET. ALIGN STD NAMES PTR AND TRY AGAIN
15441: #
15442: cnc05: addl2 $4,r9 # bump standard names ptr
15443: sobgtr r6,cnc05 # loop
15444: incl r7 # bump names offset
15445: sobgtr r8,cnc02 # continue if more names
15446: #
15447: # INVALID CONTROL CARD NAME
15448: #
15449: cnc06: jmp er_247 # invalid control card
15450: #
15451: # SPECIAL PROCESSING FOR -INXXX
15452: #
15453: cnc07: movzbl (r9),r6 # get next char
15454: bicl2 $ch$bl,r6 # fold to upper case
15455: cmpl r6,$ch$ln # fail if not letter n
15456: beqlu 0f
15457: jmp cnc06
15458: 0:
15459: addl2 $num02,scnpt # bump offset past -in
15460: jsb scane # scan integer after -in
15461: movl r9,-(sp) # stack scanned item
15462: jsb gtsmi # check if integer
15463: .long cnc06 # fail if not integer
15464: .long cnc06 # fail if negative or large
15465: movl r9,cswin # keep integer
15466: #page
15467: #
15468: # CNCRD (CONTINUED)
15469: #
15470: # CHECK FOR MORE CONTROL CARDS BEFORE RETURNING
15471: #
15472: cnc08: movl scnpt,r6 # preserve in case xeq time compile
15473: jsb scane # look for comma
15474: cmpl r10,$t$cma # loop if comma found
15475: bnequ 0f
15476: jmp cnc01
15477: 0:
15478: movl r6,scnpt # restore scnpt in case xeq time
15479: #
15480: # RETURN POINT
15481: #
15482: cnc09: rsb # return
15483: #
15484: # -DOUBLE
15485: #
15486: cnc10: movl sp,cswdb # set switch
15487: jmp cnc08 # merge
15488: #
15489: # -DUMP
15490: # THIS IS USED FOR SYSTEM DEBUGGING . IT HAS THE EFFECT OF
15491: # PRODUCING A CORE DUMP AT COMPILATION TIME
15492: #
15493: cnc11: jsb sysdm # call dumper
15494: jmp cnc09 # finished
15495: #
15496: # -EJECT
15497: #
15498: cnc12: tstl cswls # return if -nolist
15499: bnequ 0f
15500: jmp cnc09
15501: 0:
15502: jsb prtps # eject
15503: jsb listt # list title
15504: jmp cnc09 # finished
15505: #
15506: # -ERRORS
15507: #
15508: cnc13: clrl cswer # clear switch
15509: jmp cnc08 # merge
15510: #
15511: # -EXECUTE
15512: #
15513: cnc14: clrl cswex # clear switch
15514: jmp cnc08 # merge
15515: #
15516: # -FAIL
15517: #
15518: cnc15: movl sp,cswfl # set switch
15519: jmp cnc08 # merge
15520: #
15521: # -LIST
15522: #
15523: cnc16: movl sp,cswls # set switch
15524: cmpl stage,$stgic # done if compile time
15525: beqlu cnc08
15526: #
15527: # LIST CODE LINE IF EXECUTE TIME COMPILE
15528: #
15529: clrl lstpf # permit listing
15530: jsb listr # list line
15531: jmp cnc08 # merge
15532: #page
15533: #
15534: # CNCRD (CONTINUED)
15535: #
15536: # -NOERRORS
15537: #
15538: cnc17: movl sp,cswer # set switch
15539: jmp cnc08 # merge
15540: #
15541: # -NOEXECUTE
15542: #
15543: cnc18: movl sp,cswex # set switch
15544: jmp cnc08 # merge
15545: #
15546: # -NOFAIL
15547: #
15548: cnc19: clrl cswfl # clear switch
15549: jmp cnc08 # merge
15550: #
15551: # -NOLIST
15552: #
15553: cnc20: clrl cswls # clear switch
15554: jmp cnc08 # merge
15555: #
15556: # -NOOPTIMISE
15557: #
15558: cnc21: movl sp,cswno # set switch
15559: jmp cnc08 # merge
15560: #
15561: # -NOPRINT
15562: #
15563: cnc22: clrl cswpr # clear switch
15564: jmp cnc08 # merge
15565: #
15566: # -OPTIMISE
15567: #
15568: cnc24: clrl cswno # clear switch
15569: jmp cnc08 # merge
15570: #
15571: # -PRINT
15572: #
15573: cnc25: movl sp,cswpr # set switch
15574: jmp cnc08 # merge
15575: #page
15576: #
15577: # CNCRD (CONTINUED)
15578: #
15579: # -SINGLE
15580: #
15581: cnc27: clrl cswdb # clear switch
15582: jmp cnc08 # merge
15583: #
15584: # -SPACE
15585: #
15586: cnc28: tstl cswls # return if -nolist
15587: bnequ 0f
15588: jmp cnc09
15589: 0:
15590: jsb scane # scan integer after -space
15591: movl $num01,r8 # 1 space in case
15592: cmpl r9,$t$smc # jump if no integer
15593: beqlu cnc29
15594: movl r9,-(sp) # stack it
15595: jsb gtsmi # check integer
15596: .long cnc06 # fail if not integer
15597: .long cnc06 # fail if negative or large
15598: tstl r8 # jump if non zero
15599: bnequ cnc29
15600: movl $num01,r8 # else 1 space
15601: #
15602: # MERGE WITH COUNT OF LINES TO SKIP
15603: #
15604: cnc29: addl2 r8,lstlc # bump line count
15605: # convert to loop counter
15606: cmpl lstlc,lstnp # jump if fits on page
15607: blssu cnc30
15608: jsb prtps # eject
15609: jsb listt # list title
15610: jmp cnc09 # merge
15611: #
15612: # SKIP LINES
15613: #
15614: cnc30: jsb prtnl # print a blank
15615: sobgtr r8,cnc30 # loop
15616: jmp cnc09 # merge
15617: #page
15618: #
15619: # CNCRD (CONTINUED)
15620: #
15621: # -STITL
15622: #
15623: cnc31: movl $r$stl,cnr$t # ptr to r$stl
15624: jmp cnc33 # merge
15625: #
15626: # -TITLE
15627: #
15628: cnc32: movl $nulls,r$stl # clear subtitle
15629: movl $r$ttl,cnr$t # ptr to r$ttl
15630: #
15631: # COMMON PROCESSING FOR -TITLE, -STITL
15632: #
15633: cnc33: movl $nulls,r9 # null in case needed
15634: movl sp,cnttl # set flag for next listr call
15635: movl $ccofs,r7 # offset to title/subtitle
15636: movl scnil,r6 # input image length
15637: cmpl r6,r7 # jump if no chars left
15638: blequ cnc34
15639: subl2 r7,r6 # no of chars to extract
15640: movl r$cim,r10 # point to image
15641: jsb sbstr # get title/subtitle
15642: #
15643: # STORE TITLE/SUBTITLE
15644: #
15645: cnc34: movl cnr$t,r10 # point to storage location
15646: movl r9,(r10) # store title/subtitle
15647: cmpl r10,$r$stl # return if stitl
15648: bnequ 0f
15649: jmp cnc09
15650: 0:
15651: tstl precl # return if extended listing
15652: beqlu 0f
15653: jmp cnc09
15654: 0:
15655: tstl prich # return if regular printer
15656: bnequ 0f
15657: jmp cnc09
15658: 0:
15659: movl 4*sclen(r9),r10 # get length of title
15660: movl r10,r6 # copy it
15661: tstl r10 # jump if null
15662: beqlu cnc35
15663: addl2 $num10,r10 # increment
15664: cmpl r10,prlen # use default lstp0 val if too long
15665: blssu 0f
15666: jmp cnc09
15667: 0:
15668: addl2 $num04,r6 # point just past title
15669: #
15670: # STORE OFFSET TO PAGE NN MESSAGE FOR SHORT TITLE
15671: #
15672: cnc35: movl r6,lstpo # store offset
15673: jmp cnc09 # return
15674: #
15675: # -TRACE
15676: # PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL
15677: # TRACE SWITCH AT COMPILE TIME
15678: #
15679: cnc36: jsb systt # toggle switch
15680: jmp cnc08 # merge
15681: #
15682: # -CASE
15683: # SETS VALUE OF KVCAS SO THAT NAMES ARE FOLDED OR NOT
15684: # DURING COMPILATION.
15685: #
15686: cnc37: jsb scane # scan integer after -case
15687: clrl r8 # get 0 in case none there
15688: cmpl r10,$t$smc # skip if no integer
15689: beqlu cnc38
15690: movl r9,-(sp) # stack it
15691: jsb gtsmi # check integer
15692: .long cnc06 # fail if not integer
15693: .long cnc06 # fail if negative or too large
15694: cnc38: movl r8,kvcas # store new case value
15695: jmp cnc09 # merge
15696: #enp # end procedure cncrd
15697: #page
15698: #
15699: # DFFNC -- DEFINE FUNCTION
15700: #
15701: # DFFNC IS CALLED WHENEVER A NEW FUNCTION IS ASSIGNED TO
15702: # A VARIABLE. IT DEALS WITH EXTERNAL FUNCTION USE COUNTS.
15703: #
15704: # (XR) POINTER TO VRBLK
15705: # (XL) POINTER TO NEW FUNCTION BLOCK
15706: # JSR DFFNC CALL TO DEFINE FUNCTION
15707: # (WA,WB) DESTROYED
15708: #
15709: dffnc: #prc # entry point
15710: cmpl (r10),$b$efc # skip if new function not external
15711: bnequ dffn1
15712: incl 4*efuse(r10) # else increment its use count
15713: #
15714: # HERE AFTER DEALING WITH NEW FUNCTION USE COUNT
15715: #
15716: dffn1: movl r9,r6 # save vrblk pointer
15717: movl 4*vrfnc(r9),r9 # load old function pointer
15718: cmpl (r9),$b$efc # jump if old function not external
15719: bnequ dffn2
15720: movl 4*efuse(r9),r7 # else get use count
15721: decl r7 # decrement
15722: movl r7,4*efuse(r9) # store decremented value
15723: tstl r7 # jump if use count still non-zero
15724: bnequ dffn2
15725: jsb sysul # else call system unload function
15726: #
15727: # HERE AFTER DEALING WITH OLD FUNCTION USE COUNT
15728: #
15729: dffn2: movl r6,r9 # restore vrblk pointer
15730: movl r10,r6 # copy function block ptr
15731: cmpl r9,$r$yyy # skip checks if opsyn op definition
15732: blssu dffn3
15733: tstl 4*vrlen(r9) # jump if not system variable
15734: bnequ dffn3
15735: #
15736: # FOR SYSTEM VARIABLE, CHECK FOR ILLEGAL REDEFINITION
15737: #
15738: movl 4*vrsvp(r9),r10 # point to svblk
15739: movl 4*svbit(r10),r7 # load bit indicators
15740: mcoml btfnc,r11 # is it a system function
15741: bicl2 r11,r7
15742: tstl r7 # redef ok if not
15743: beqlu dffn3
15744: jmp er_248 # attempted redefinition of system function
15745: #
15746: # HERE IF REDEFINITION IS PERMITTED
15747: #
15748: dffn3: movl r6,4*vrfnc(r9) # store new function pointer
15749: movl r6,r10 # restore function block pointer
15750: rsb # return to dffnc caller
15751: #enp # end procedure dffnc
15752: #page
15753: #
15754: # DTACH -- DETACH I/O ASSOCIATED NAMES
15755: #
15756: # DETACHES TRBLKS FROM I/O ASSOCIATED VARIABLES, REMOVES
15757: # ENTRY FROM IOCHN CHAIN ATTACHED TO FILEARG1 VRBLK AND MAY
15758: # REMOVE VRBLK ACCESS AND STORE TRAPS.
15759: # INPUT, OUTPUT, TERMINAL ARE HANDLED SPECIALLY.
15760: #
15761: # (XL) I/O ASSOC. VBL NAME BASE PTR
15762: # (WA) OFFSET TO NAME
15763: # JSR DTACH CALL FOR DETACH OPERATION
15764: # (XL,XR,WA,WB,WC) DESTROYED
15765: #
15766: dtach: #prc # entry point
15767: movl r10,dtcnb # store name base (gbcol not called)
15768: addl2 r6,r10 # point to name location
15769: movl r10,dtcnm # store it
15770: #
15771: # LOOP TO SEARCH FOR I/O TRBLK
15772: #
15773: dtch1: movl r10,r9 # copy name pointer
15774: #
15775: # CONTINUE AFTER BLOCK DELETION
15776: #
15777: dtch2: movl (r10),r10 # point to next value
15778: cmpl (r10),$b$trt # jump at chain end
15779: bnequ dtch6
15780: movl 4*trtyp(r10),r6 # get trap block type
15781: cmpl r6,$trtin # jump if input
15782: beqlu dtch3
15783: cmpl r6,$trtou # jump if output
15784: beqlu dtch3
15785: addl2 $4*trnxt,r10 # point to next link
15786: jmp dtch1 # loop
15787: #
15788: # DELETE AN OLD ASSOCIATION
15789: #
15790: dtch3: movl 4*trval(r10),(r9)# delete trblk
15791: movl r10,r6 # dump xl ...
15792: movl r9,r7 # ... and xr
15793: movl 4*trtrf(r10),r10# point to trtrf trap block
15794: tstl r10 # jump if no iochn
15795: beqlu dtch5
15796: cmpl (r10),$b$trt # jump if input, output, terminal
15797: bnequ dtch5
15798: #
15799: # LOOP TO SEARCH IOCHN CHAIN FOR NAME PTR
15800: #
15801: dtch4: movl r10,r9 # remember link ptr
15802: movl 4*trtrf(r10),r10# point to next link
15803: tstl r10 # jump if end of chain
15804: beqlu dtch5
15805: movl 4*ionmb(r10),r8 # get name base
15806: addl2 4*ionmo(r10),r8 # add offset
15807: cmpl r8,dtcnm # loop if no match
15808: bnequ dtch4
15809: movl 4*trtrf(r10),4*trtrf(r9) # remove name from chain
15810: #page
15811: #
15812: # DTACH (CONTINUED)
15813: #
15814: # PREPARE TO RESUME I/O TRBLK SCAN
15815: #
15816: dtch5: movl r6,r10 # recover xl ...
15817: movl r7,r9 # ... and xr
15818: addl2 $4*trval,r10 # point to value field
15819: jmp dtch2 # continue
15820: #
15821: # EXIT POINT
15822: #
15823: dtch6: movl dtcnb,r9 # possible vrblk ptr
15824: jsb setvr # reset vrblk if necessary
15825: rsb # return
15826: #enp # end procedure dtach
15827: #page
15828: #
15829: # DTYPE -- GET DATATYPE NAME
15830: #
15831: # (XR) OBJECT WHOSE DATATYPE IS REQUIRED
15832: # JSR DTYPE CALL TO GET DATATYPE
15833: # (XR) RESULT DATATYPE
15834: #
15835: dtype: #prc # entry point
15836: cmpl (r9),$b$pdt # jump if prog.defined
15837: beqlu dtyp1
15838: movl (r9),r9 # load type word
15839: movzwl -2(r9),r9 # get entry point id (block code)
15840: moval 0[r9],r9 # convert to byte offset
15841: movl l^scnmt(r9),r9 # load table entry
15842: rsb # exit to dtype caller
15843: #
15844: # HERE IF PROGRAM DEFINED
15845: #
15846: dtyp1: movl 4*pddfp(r9),r9 # point to dfblk
15847: movl 4*dfnam(r9),r9 # get datatype name from dfblk
15848: rsb # return to dtype caller
15849: #enp # end procedure dtype
15850: #page
15851: #
15852: # DUMPR -- PRINT DUMP OF STORAGE
15853: #
15854: # (XR) DUMP ARGUMENT (SEE BELOW)
15855: # JSR DUMPR CALL TO PRINT DUMP
15856: # (XR,XL) DESTROYED
15857: # (WA,WB,WC,RA) DESTROYED
15858: #
15859: # THE DUMP ARGUMENT HAS THE FOLLOWING SIGNIFICANCE
15860: #
15861: # DMARG = 0 NO DUMP PRINTED
15862: # DMARG = 1 PARTIAL DUMP (NAT VARS, KEYWORDS)
15863: # DMARG EQ 2 FULL DUMP (INCL ARRAYS ETC.)
15864: # DMARG GE 3 CORE DUMP
15865: #
15866: # SINCE DUMPR SCRAMBLES STORE, IT IS NOT PERMISSIBLE TO
15867: # COLLECT IN MID-DUMP. HENCE A COLLECT IS DONE INITIALLY
15868: # AND THEN IF STORE RUNS OUT AN ERROR MESSAGE IS PRODUCED.
15869: #
15870: dumpr: #prc # entry point
15871: tstl r9 # skip dump if argument is zero
15872: bnequ 0f
15873: jmp dmp28
15874: 0:
15875: cmpl r9,$num02 # jump if core dump required
15876: blequ 0f
15877: jmp dmp29
15878: 0:
15879: clrl r10 # clear xl
15880: clrl r7 # zero move offset
15881: movl r9,dmarg # save dump argument
15882: jsb gbcol # collect garbage
15883: jsb prtpg # eject printer
15884: movl $dmhdv,r9 # point to heading for variables
15885: jsb prtst # print it
15886: jsb prtnl # terminate print line
15887: jsb prtnl # and print a blank line
15888: #
15889: # FIRST ALL NATURAL VARIABLE BLOCKS (VRBLK) WHOSE VALUES
15890: # ARE NON-NULL ARE LINKED IN LEXICAL ORDER USING DMVCH AS
15891: # THE CHAIN HEAD AND CHAINING THROUGH THE VRGET FIELDS.
15892: # NOTE THAT THIS SCRAMBLES STORE IF THE PROCESS IS
15893: # INTERRUPTED BEFORE COMPLETION E.G. BY EXCEEDING TIME OR
15894: # PRINT LIMITS. SINCE THE SUBSEQUENT CORE DUMPS AND
15895: # FAILURES IF EXECUTION IS RESUMED ARE VERY CONFUSING, THE
15896: # EXECUTION TIME ERROR ROUTINE CHECKS FOR THIS EVENT AND
15897: # ATTEMPTS AN UNSCRAMBLE. SIMILAR PRECAUTIONS SHOULD BE
15898: # OBSERVED IF TRANSLATE TIME DUMPING IS IMPLEMENTED.
15899: #
15900: clrl dmvch # set null chain to start
15901: movl hshtb,r6 # point to hash table
15902: #
15903: # LOOP THROUGH HEADERS IN HASH TABLE
15904: #
15905: dmp00: movl r6,r9 # copy hash bucket pointer
15906: addl2 $4,r6 # bump pointer
15907: subl2 $4*vrnxt,r9 # set offset to merge
15908: #
15909: # LOOP THROUGH VRBLKS ON ONE CHAIN
15910: #
15911: dmp01: movl 4*vrnxt(r9),r9 # point to next vrblk on chain
15912: tstl r9 # jump if end of this hash chain
15913: bnequ 0f
15914: jmp dmp09
15915: 0:
15916: movl r9,r10 # else copy vrblk pointer
15917: #page
15918: #
15919: # DUMPR (CONTINUED)
15920: #
15921: # LOOP TO FIND VALUE AND SKIP IF NULL
15922: #
15923: dmp02: movl 4*vrval(r10),r10# load value
15924: cmpl r10,$nulls # loop for next vrblk if null value
15925: beqlu dmp01
15926: cmpl (r10),$b$trt # loop back if value is trapped
15927: beqlu dmp02
15928: #
15929: # NON-NULL VALUE, PREPARE TO SEARCH CHAIN
15930: #
15931: movl r9,r8 # save vrblk pointer
15932: addl2 $4*vrsof,r9 # adjust ptr to be like scblk ptr
15933: tstl 4*sclen(r9) # jump if non-system variable
15934: bnequ dmp03
15935: movl 4*vrsvo(r9),r9 # else load ptr to name in svblk
15936: #
15937: # HERE WITH NAME POINTER FOR NEW BLOCK IN XR
15938: #
15939: dmp03: movl r9,r7 # save pointer to chars
15940: movl r6,dmpsv # save hash bucket pointer
15941: movl $dmvch,r6 # point to chain head
15942: #
15943: # LOOP TO SEARCH CHAIN FOR CORRECT INSERTION POINT
15944: #
15945: dmp04: movl r6,dmpch # save chain pointer
15946: movl r6,r10 # copy it
15947: movl (r10),r9 # load pointer to next entry
15948: tstl r9 # jump if end of chain to insert
15949: bnequ 0f
15950: jmp dmp08
15951: 0:
15952: addl2 $4*vrsof,r9 # else get name ptr for chained vrblk
15953: tstl 4*sclen(r9) # jump if not system variable
15954: bnequ dmp05
15955: movl 4*vrsvo(r9),r9 # else point to name in svblk
15956: #
15957: # HERE PREPARE TO COMPARE THE NAMES
15958: #
15959: # (WA) SCRATCH
15960: # (WB) POINTER TO STRING OF ENTERING VRBLK
15961: # (WC) POINTER TO ENTERING VRBLK
15962: # (XR) POINTER TO STRING OF CURRENT BLOCK
15963: # (XL) SCRATCH
15964: #
15965: dmp05: movl r7,r10 # point to entering vrblk string
15966: movl 4*sclen(r10),r6 # load its length
15967: movab cfp$f(r10),r10 # point to chars of entering string
15968: cmpl r6,4*sclen(r9) # jump if entering length high
15969: bgequ dmp06
15970: movab cfp$f(r9),r9 # else point to chars of old string
15971: jsb sbcmc # compare, insert if new is llt old
15972: .long dmp08
15973: .long dmp07
15974: jmp dmp08 # or if leq (we had shorter length)
15975: #
15976: # HERE WHEN NEW LENGTH IS LONGER THAN OLD LENGTH
15977: #
15978: dmp06: movl 4*sclen(r9),r6 # load shorter length
15979: movab cfp$f(r9),r9 # point to chars of old string
15980: jsb sbcmc # compare, insert if new one low
15981: .long dmp08
15982: .long dmp07
15983: #page
15984: #
15985: # DUMPR (CONTINUED)
15986: #
15987: # HERE WE MOVE OUT ON THE CHAIN
15988: #
15989: dmp07: movl dmpch,r10 # copy chain pointer
15990: movl (r10),r6 # move to next entry on chain
15991: jmp dmp04 # loop back
15992: #
15993: # HERE AFTER LOCATING THE PROPER INSERTION POINT
15994: #
15995: dmp08: movl dmpch,r10 # copy chain pointer
15996: movl dmpsv,r6 # restore hash bucket pointer
15997: movl r8,r9 # restore vrblk pointer
15998: movl (r10),4*vrget(r9)# link vrblk to rest of chain
15999: movl r9,(r10) # link vrblk into current chain loc
16000: jmp dmp01 # loop back for next vrblk
16001: #
16002: # HERE AFTER PROCESSING ALL VRBLKS ON ONE CHAIN
16003: #
16004: dmp09: cmpl r6,hshte # loop back if more buckets to go
16005: beqlu 0f
16006: jmp dmp00
16007: 0:
16008: #
16009: # LOOP TO GENERATE DUMP OF NATURAL VARIABLE VALUES
16010: #
16011: dmp10: movl dmvch,r9 # load pointer to next entry on chain
16012: tstl r9 # jump if end of chain
16013: beqlu dmp11
16014: movl (r9),dmvch # else update chain ptr to next entry
16015: jsb setvr # restore vrget field
16016: movl r9,r10 # copy vrblk pointer (name base)
16017: movl $4*vrval,r6 # set offset for vrblk name
16018: jsb prtnv # print name = value
16019: jmp dmp10 # loop back till all printed
16020: #
16021: # PREPARE TO PRINT KEYWORDS
16022: #
16023: dmp11: jsb prtnl # print blank line
16024: jsb prtnl # and another
16025: movl $dmhdk,r9 # point to keyword heading
16026: jsb prtst # print heading
16027: jsb prtnl # end line
16028: jsb prtnl # print one blank line
16029: movl $vdmkw,r10 # point to list of keyword svblk ptrs
16030: #page
16031: #
16032: # DUMPR (CONTINUED)
16033: #
16034: # LOOP TO DUMP KEYWORD VALUES
16035: #
16036: dmp12: movl (r10)+,r9 # load next svblk ptr from table
16037: tstl r9 # jump if end of list
16038: beqlu dmp13
16039: movl $ch$am,r6 # load ampersand
16040: jsb prtch # print ampersand
16041: jsb prtst # print keyword name
16042: movl 4*svlen(r9),r6 # load name length from svblk
16043: movab 3+(4*svchs)(r6),r6 # get length of name
16044: bicl2 $3,r6
16045: addl2 r6,r9 # point to svknm field
16046: movl (r9),dmpkn # store in dummy kvblk
16047: movl $tmbeb,r9 # point to blank-equal-blank
16048: jsb prtst # print it
16049: movl r10,dmpsv # save table pointer
16050: movl $dmpkb,r10 # point to dummy kvblk
16051: movl $4*kvvar,r6 # set zero offset
16052: jsb acess # get keyword value
16053: .long invalid$ # failure is impossible
16054: jsb prtvl # print keyword value
16055: jsb prtnl # terminate print line
16056: movl dmpsv,r10 # restore table pointer
16057: jmp dmp12 # loop back till all printed
16058: #
16059: # HERE AFTER COMPLETING PARTIAL DUMP
16060: #
16061: dmp13: cmpl dmarg,$num01 # exit if partial dump complete
16062: bnequ 0f
16063: jmp dmp27
16064: 0:
16065: movl dnamb,r9 # else point to first dynamic block
16066: #
16067: # LOOP THROUGH BLOCKS IN DYNAMIC STORAGE
16068: #
16069: dmp14: cmpl r9,dnamp # jump if end of used region
16070: bnequ 0f
16071: jmp dmp27
16072: 0:
16073: movl (r9),r6 # else load first word of block
16074: cmpl r6,$b$vct # jump if vector
16075: beqlu dmp16
16076: cmpl r6,$b$art # jump if array
16077: beqlu dmp17
16078: cmpl r6,$b$pdt # jump if program defined
16079: beqlu dmp18
16080: cmpl r6,$b$tbt # jump if table
16081: beqlu dmp19
16082: cmpl r6,$b$bct # jump if buffer
16083: bnequ 0f
16084: jmp dmp30
16085: 0:
16086: #
16087: # MERGE HERE TO MOVE TO NEXT BLOCK
16088: #
16089: dmp15: jsb blkln # get length of block
16090: addl2 r6,r9 # point past this block
16091: jmp dmp14 # loop back for next block
16092: #page
16093: #
16094: # DUMPR (CONTINUED)
16095: #
16096: # HERE FOR VECTOR
16097: #
16098: dmp16: movl $4*vcvls,r7 # set offset to first value
16099: jmp dmp19 # jump to merge
16100: #
16101: # HERE FOR ARRAY
16102: #
16103: dmp17: movl 4*arofs(r9),r7 # set offset to arpro field
16104: addl2 $4,r7 # bump to get offset to values
16105: jmp dmp19 # jump to merge
16106: #
16107: # HERE FOR PROGRAM DEFINED
16108: #
16109: dmp18: movl $4*pdfld,r7 # point to values, merge
16110: #
16111: # HERE FOR TABLE (OTHERS MERGE)
16112: #
16113: dmp19: tstl 4*idval(r9) # ignore block if zero id value
16114: bnequ 0f
16115: jmp dmp15
16116: 0:
16117: jsb blkln # else get block length
16118: movl r9,r10 # copy block pointer
16119: movl r6,dmpsv # save length
16120: movl r7,r6 # copy offset to first value
16121: jsb prtnl # print blank line
16122: movl r6,dmpsa # preserve offset
16123: jsb prtvl # print block value (for title)
16124: movl dmpsa,r6 # recover offset
16125: jsb prtnl # end print line
16126: cmpl (r9),$b$tbt # jump if table
16127: beqlu dmp22
16128: subl2 $4,r6 # point before first word
16129: #
16130: # LOOP TO PRINT CONTENTS OF ARRAY, VECTOR, OR PROGRAM DEF
16131: #
16132: dmp20: movl r10,r9 # copy block pointer
16133: addl2 $4,r6 # bump offset
16134: addl2 r6,r9 # point to next value
16135: cmpl r6,dmpsv # exit if end (xr past block)
16136: bnequ 0f
16137: jmp dmp14
16138: 0:
16139: subl2 $4*vrval,r9 # subtract offset to merge into loop
16140: #
16141: # LOOP TO FIND VALUE AND IGNORE NULLS
16142: #
16143: dmp21: movl 4*vrval(r9),r9 # load next value
16144: cmpl r9,$nulls # loop back if null value
16145: beqlu dmp20
16146: cmpl (r9),$b$trt # loop back if trapped
16147: beqlu dmp21
16148: jsb prtnv # else print name = value
16149: jmp dmp20 # loop back for next field
16150: #page
16151: #
16152: # DUMPR (CONTINUED)
16153: #
16154: # HERE TO DUMP A TABLE
16155: #
16156: dmp22: movl $4*tbbuk,r8 # set offset to first bucket
16157: movl $4*teval,r6 # set name offset for all teblks
16158: #
16159: # LOOP THROUGH TABLE BUCKETS
16160: #
16161: dmp23: movl r10,-(sp) # save tbblk pointer
16162: addl2 r8,r10 # point to next bucket header
16163: addl2 $4,r8 # bump bucket offset
16164: subl2 $4*tenxt,r10 # subtract offset to merge into loop
16165: #
16166: # LOOP TO PROCESS TEBLKS ON ONE CHAIN
16167: #
16168: dmp24: movl 4*tenxt(r10),r10# point to next teblk
16169: cmpl r10,(sp) # jump if end of chain
16170: beqlu dmp26
16171: movl r10,r9 # else copy teblk pointer
16172: #
16173: # LOOP TO FIND VALUE AND IGNORE IF NULL
16174: #
16175: dmp25: movl 4*teval(r9),r9 # load next value
16176: cmpl r9,$nulls # ignore if null value
16177: beqlu dmp24
16178: cmpl (r9),$b$trt # loop back if trapped
16179: beqlu dmp25
16180: movl r8,dmpsv # else save offset pointer
16181: jsb prtnv # print name = value
16182: movl dmpsv,r8 # reload offset
16183: jmp dmp24 # loop back for next teblk
16184: #
16185: # HERE TO MOVE TO NEXT HASH CHAIN
16186: #
16187: dmp26: movl (sp)+,r10 # restore tbblk pointer
16188: cmpl r8,4*tblen(r10) # loop back if more buckets to go
16189: bnequ dmp23
16190: movl r10,r9 # else copy table pointer
16191: addl2 r8,r9 # point to following block
16192: jmp dmp14 # loop back to process next block
16193: #
16194: # HERE AFTER COMPLETING DUMP
16195: #
16196: dmp27: jsb prtpg # eject printer
16197: #
16198: # MERGE HERE IF NO DUMP GIVEN (DMARG=0)
16199: #
16200: dmp28: rsb # return to dump caller
16201: #
16202: # CALL SYSTEM CORE DUMP ROUTINE
16203: #
16204: dmp29: jsb sysdm # call it
16205: jmp dmp28 # return
16206: #page
16207: #
16208: # DUMPR (CONTINUED)
16209: #
16210: # HERE TO DUMP BUFFER BLOCK
16211: #
16212: dmp30: jsb prtnl # print blank line
16213: jsb prtvl # print value id for title
16214: jsb prtnl # force new line
16215: movl $ch$dq,r6 # load double quote
16216: jsb prtch # print it
16217: movl 4*bclen(r9),r8 # load defined length
16218: tstl r8 # skip characters if none
16219: beqlu dmp32
16220: # load count for loop
16221: movl r9,r7 # save bcblk ptr
16222: movl 4*bcbuf(r9),r9 # point to bfblk
16223: movab cfp$f(r9),r9 # get set to load characters
16224: #
16225: # LOOP HERE STUFFING CHARACTERS IN OUTPUT STREAM
16226: #
16227: dmp31: movzbl (r9)+,r6 # get next character
16228: jsb prtch # stuff it
16229: sobgtr r8,dmp31 # branch for next one
16230: movl r7,r9 # restore bcblk pointer
16231: #
16232: # MERGE TO STUFF CLOSING QUOTE MARK
16233: #
16234: dmp32: movl $ch$dq,r6 # stuff quote
16235: jsb prtch # print it
16236: jsb prtnl # print new line
16237: movl (r9),r6 # get first wd for blkln
16238: jmp dmp15 # merge to get next block
16239: #enp # end procedure dumpr
16240: #page
16241: #
16242: # ERMSG -- PRINT ERROR CODE AND ERROR MESSAGE
16243: #
16244: # KVERT ERROR CODE
16245: # JSR ERMSG CALL TO PRINT MESSAGE
16246: # (XR,XL,WA,WB,WC,IA) DESTROYED
16247: #
16248: ermsg: #prc # entry point
16249: jsb prtis # print error ptr or blank line
16250: movl kvert,r6 # load error code
16251: movl $ermms,r9 # point to error message /error/
16252: jsb prtst # print it
16253: jsb ertex # get error message text
16254: addl2 $thsnd,r6 # bump error code for print
16255: movl r6,r5 # fail code in int acc
16256: jsb prtin # print code (now have error1xxx)
16257: movl prbuf,r10 # point to print buffer
16258: movl $num05,r11 # [get in scratch register]
16259: movab cfp$f(r10)[r11],r10 # point to the 1
16260: movl $ch$bl,r6 # load a blank
16261: movb r6,(r10) # store blank over 1 (error xxx)
16262: #csc r10 # complete store characters
16263: clrl r10 # clear garbage pointer in xl
16264: movl r9,r6 # keep error text
16265: movl $ermns,r9 # point to / -- /
16266: jsb prtst # print it
16267: movl r6,r9 # get error text again
16268: jsb prtst # print error message text
16269: jsb prtis # print line
16270: jsb prtis # print blank line
16271: rsb # return to ermsg caller
16272: #enp # end procedure ermsg
16273: #page
16274: #
16275: # ERTEX -- GET ERROR MESSAGE TEXT
16276: #
16277: # (WA) ERROR CODE
16278: # JSR ERTEX CALL TO GET ERROR TEXT
16279: # (XR) PTR TO ERROR TEXT IN DYNAMIC
16280: # (R$ETX) COPY OF PTR TO ERROR TEXT
16281: # (XL,WC,IA) DESTROYED
16282: #
16283: ertex: #prc # entry point
16284: movl r6,ertwa # save wa
16285: movl r7,ertwb # save wb
16286: jsb sysem # get failure message text
16287: movl r9,r10 # copy pointer to it
16288: movl 4*sclen(r9),r6 # get length of string
16289: tstl r6 # jump if null
16290: beqlu ert02
16291: clrl r7 # offset of zero
16292: jsb sbstr # copy into dynamic store
16293: movl r9,r$etx # store for relocation
16294: #
16295: # RETURN
16296: #
16297: ert01: movl ertwb,r7 # restore wb
16298: movl ertwa,r6 # restore wa
16299: rsb # return to caller
16300: #
16301: # RETURN ERRTEXT CONTENTS INSTEAD OF NULL
16302: #
16303: ert02: movl r$etx,r9 # get errtext
16304: jmp ert01 # return
16305: #enp
16306: #page
16307: #
16308: # EVALI -- EVALUATE INTEGER ARGUMENT
16309: #
16310: # EVALI IS USED BY PATTERN PRIMITIVES LEN,TAB,RTAB,POS,RPOS
16311: # WHEN THEIR ARGUMENT IS AN EXPRESSION VALUE.
16312: #
16313: # (XR) NODE POINTER
16314: # (WB) CURSOR
16315: # JSR EVALI CALL TO EVALUATE INTEGER
16316: # PPM LOC TRANSFER LOC FOR NON-INTEGER ARG
16317: # PPM LOC TRANSFER LOC FOR OUT OF RANGE ARG
16318: # PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
16319: # PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL
16320: # (THE NORMAL RETURN IS NEVER TAKEN)
16321: # (XR) PTR TO NODE WITH INTEGER ARGUMENT
16322: # (WC,XL,RA) DESTROYED
16323: #
16324: # ON RETURN, THE NODE POINTED TO HAS THE INTEGER ARGUMENT
16325: # IN PARM1 AND THE PROPER SUCCESSOR POINTER IN PTHEN.
16326: # THIS ALLOWS MERGING WITH THE NORMAL (INTEGER ARG) CASE.
16327: #
16328: evali: #prc # entry point (recursive)
16329: jsb evalp # evaluate expression
16330: .long evli1 # jump on failure
16331: movl r10,-(sp) # stack result for gtsmi
16332: movl 4*pthen(r9),r10 # load successor pointer
16333: jsb gtsmi # convert arg to small integer
16334: .long evli2 # jump if not integer
16335: .long evli3 # jump if out of range
16336: movl r9,evliv # store result in special dummy node
16337: movl r10,evlis # store successor pointer
16338: movl $evlin,r9 # point to dummy node with result
16339: addl3 $4*3,(sp)+,r11 # take successful exit
16340: jmp *(r11)+
16341: #
16342: # HERE IF EVALUATION FAILS
16343: #
16344: evli1: addl3 $4*2,(sp)+,r11 # take failure return
16345: jmp *(r11)+
16346: #
16347: # HERE IF ARGUMENT IS NOT INTEGER
16348: #
16349: evli2: movl (sp)+,r11 # take non-integer error exit
16350: jmp *(r11)+
16351: #
16352: # HERE IF ARGUMENT IS OUT OF RANGE
16353: #
16354: evli3: addl3 $4*1,(sp)+,r11 # take out-of-range error exit
16355: jmp *(r11)+
16356: #enp # end procedure evali
16357: #page
16358: #
16359: # EVALP -- EVALUATE EXPRESSION DURING PATTERN MATCH
16360: #
16361: # EVALP IS USED TO EVALUATE AN EXPRESSION (BY VALUE) DURING
16362: # A PATTERN MATCH. THE EFFECT IS LIKE EVALX, BUT PATTERN
16363: # VARIABLES ARE STACKED AND RESTORED IF NECESSARY.
16364: #
16365: # EVALP ALSO DIFFERS FROM EVALX IN THAT IF THE RESULT IS
16366: # AN EXPRESSION IT IS REEVALUATED. THIS OCCURS REPEATEDLY.
16367: #
16368: # (XR) NODE POINTER
16369: # (WB) PATTERN MATCH CURSOR
16370: # JSR EVALP CALL TO EVALUATE EXPRESSION
16371: # PPM LOC TRANSFER LOC IF EVALUATION FAILS
16372: # (XL) RESULT
16373: # (WA) FIRST WORD OF RESULT BLOCK
16374: # (XR,WB) DESTROYED (FAILURE CASE ONLY)
16375: # (WC,RA) DESTROYED
16376: #
16377: # THE EXPRESSION POINTER IS STORED IN PARM1 OF THE NODE
16378: #
16379: # CONTROL RETURNS TO FAILP ON FAILURE OF EVALUATION
16380: #
16381: evalp: #prc # entry point (recursive)
16382: movl 4*parm1(r9),r10 # load expression pointer
16383: cmpl (r10),$b$exl # jump if exblk case
16384: beqlu evlp1
16385: #
16386: # HERE FOR CASE OF SEBLK
16387: #
16388: # WE CAN GIVE A FAST RETURN IF THE VALUE OF THE VRBLK IS
16389: # NOT AN EXPRESSION AND IS NOT TRAPPED.
16390: #
16391: movl 4*sevar(r10),r10# load vrblk pointer
16392: movl 4*vrval(r10),r10# load value of vrblk
16393: movl (r10),r6 # load first word of value
16394: cmpl r6,$b$t$$ # jump if not seblk, trblk or exblk
16395: bgequ evlp3
16396: #
16397: # HERE FOR EXBLK OR SEBLK WITH EXPR VALUE OR TRAPPED VALUE
16398: #
16399: evlp1: movl r9,-(sp) # stack node pointer
16400: movl r7,-(sp) # stack cursor
16401: movl r$pms,-(sp) # stack subject string pointer
16402: movl pmssl,-(sp) # stack subject string length
16403: movl pmdfl,-(sp) # stack dot flag
16404: movl pmhbs,-(sp) # stack history stack base pointer
16405: movl 4*parm1(r9),r9 # load expression pointer
16406: #page
16407: #
16408: # EVALP (CONTINUED)
16409: #
16410: # LOOP BACK HERE TO REEVALUATE EXPRESSION RESULT
16411: #
16412: evlp2: clrl r7 # set flag for by value
16413: jsb evalx # evaluate expression
16414: .long evlp4 # jump on failure
16415: movl (r9),r6 # else load first word of value
16416: cmpl r6,$b$e$$ # loop back to reevaluate expression
16417: blequ evlp2
16418: #
16419: # HERE TO RESTORE PATTERN VALUES AFTER SUCCESSFUL EVAL
16420: #
16421: movl r9,r10 # copy result pointer
16422: movl (sp)+,pmhbs # restore history stack base pointer
16423: movl (sp)+,pmdfl # restore dot flag
16424: movl (sp)+,pmssl # restore subject string length
16425: movl (sp)+,r$pms # restore subject string pointer
16426: movl (sp)+,r7 # restore cursor
16427: movl (sp)+,r9 # restore node pointer
16428: #
16429: # COMMON EXIT POINT
16430: #
16431: evlp3: addl2 $4*1,(sp) # return to evalp caller
16432: rsb
16433: #
16434: # HERE FOR FAILURE DURING EVALUATION
16435: #
16436: evlp4: movl (sp)+,pmhbs # restore history stack base pointer
16437: movl (sp)+,pmdfl # restore dot flag
16438: movl (sp)+,pmssl # restore subject string length
16439: movl (sp)+,r$pms # restore subject string pointer
16440: addl2 $4*num02,sp # remove node ptr, cursor
16441: movl (sp)+,r11 # take failure exit
16442: jmp *(r11)+
16443: #enp # end procedure evalp
16444: #page
16445: #
16446: # EVALS -- EVALUATE STRING ARGUMENT
16447: #
16448: # EVALS IS USED BY SPAN, ANY, NOTANY, BREAK, BREAKX WHEN
16449: # THEY ARE PASSED AN EXPRESSION ARGUMENT.
16450: #
16451: # (XR) NODE POINTER
16452: # (WB) CURSOR
16453: # JSR EVALS CALL TO EVALUATE STRING
16454: # PPM LOC TRANSFER LOC FOR NON-STRING ARG
16455: # PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
16456: # PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL
16457: # (THE NORMAL RETURN IS NEVER TAKEN)
16458: # (XR) PTR TO NODE WITH PARMS SET
16459: # (XL,WC,RA) DESTROYED
16460: #
16461: # ON RETURN, THE NODE POINTED TO HAS A CHARACTER TABLE
16462: # POINTER IN PARM1 AND A BIT MASK IN PARM2. THE PROPER
16463: # SUCCESSOR IS STORED IN PTHEN OF THIS NODE. THUS IT IS
16464: # OK FOR MERGING WITH THE NORMAL (MULTI-CHAR STRING) CASE.
16465: #
16466: evals: #prc # entry point (recursive)
16467: jsb evalp # evaluate expression
16468: .long evls1 # jump if evaluation fails
16469: movl 4*pthen(r9),-(sp)# save successor pointer
16470: movl r7,-(sp) # save cursor
16471: movl r10,-(sp) # stack result ptr for patst
16472: clrl r7 # dummy pcode for one char string
16473: clrl r8 # dummy pcode for expression arg
16474: movl $p$brk,r10 # appropriate pcode for our use
16475: jsb patst # call routine to build node
16476: .long evls2 # jump if not string
16477: movl (sp)+,r7 # restore cursor
16478: movl (sp)+,4*pthen(r9)# store successor pointer
16479: addl3 $4*2,(sp)+,r11 # take success return
16480: jmp *(r11)+
16481: #
16482: # HERE IF EVALUATION FAILS
16483: #
16484: evls1: addl3 $4*1,(sp)+,r11 # take failure return
16485: jmp *(r11)+
16486: #
16487: # HERE IF ARGUMENT IS NOT STRING
16488: #
16489: evls2: addl2 $4*num02,sp # pop successor and cursor
16490: movl (sp)+,r11 # take non-string error exit
16491: jmp *(r11)+
16492: #enp # end procedure evals
16493: #page
16494: #
16495: # EVALX -- EVALUATE EXPRESSION
16496: #
16497: # EVALX IS CALLED TO EVALUATE AN EXPRESSION
16498: #
16499: # (XR) POINTER TO EXBLK OR SEBLK
16500: # (WB) 0 IF BY VALUE, 1 IF BY NAME
16501: # JSR EVALX CALL TO EVALUATE EXPRESSION
16502: # PPM LOC TRANSFER LOC IF EVALUATION FAILS
16503: # (XR) RESULT IF CALLED BY VALUE
16504: # (XL,WA) RESULT NAME BASE,OFFSET IF BY NAME
16505: # (XR) DESTROYED (NAME CASE ONLY)
16506: # (XL,WA) DESTROYED (VALUE CASE ONLY)
16507: # (WB,WC,RA) DESTROYED
16508: #
16509: evalx: #prc # entry point, recursive
16510: cmpl (r9),$b$exl # jump if exblk case
16511: beqlu evlx2
16512: #
16513: # HERE FOR SEBLK
16514: #
16515: movl 4*sevar(r9),r10 # load vrblk pointer (name base)
16516: movl $4*vrval,r6 # set name offset
16517: tstl r7 # jump if called by name
16518: beqlu 0f
16519: jmp evlx1
16520: 0:
16521: jsb acess # call routine to access value
16522: .long evlx9 # jump if failure on access
16523: #
16524: # MERGE HERE TO EXIT FOR SEBLK CASE
16525: #
16526: evlx1: addl2 $4*1,(sp) # return to evalx caller
16527: rsb
16528: #page
16529: #
16530: # EVALX (CONTINUED)
16531: #
16532: # HERE FOR FULL EXPRESSION (EXBLK) CASE
16533: #
16534: # IF AN ERROR OCCURS IN THE EXPRESSION CODE AT EXECUTION
16535: # TIME, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
16536: # WITHOUT RETURNING TO THIS ROUTINE.
16537: # THE FOLLOWING ENTRIES ARE MADE ON THE STACK BEFORE
16538: # GIVING CONTROL TO THE EXPRESSION CODE
16539: #
16540: # EVALX RETURN POINT
16541: # SAVED VALUE OF R$COD
16542: # CODE POINTER (-R$COD)
16543: # SAVED VALUE OF FLPTR
16544: # 0 IF BY VALUE, 1 IF BY NAME
16545: # FLPTR --------------- *EXFLC, FAIL OFFSET IN EXBLK
16546: #
16547: evlx2: movl r3,r8 # get code pointer
16548: movl r$cod,r6 # load code block pointer
16549: subl2 r6,r8 # get code pointer as offset
16550: movl r6,-(sp) # stack old code block pointer
16551: movl r8,-(sp) # stack relative code offset
16552: movl flptr,-(sp) # stack old failure pointer
16553: movl r7,-(sp) # stack name/value indicator
16554: movl $4*exflc,-(sp) # stack new fail offset
16555: movl flptr,gtcef # keep in case of error
16556: movl r$cod,r$gtc # keep code block pointer similarly
16557: movl sp,flptr # set new failure pointer
16558: movl r9,r$cod # set new code block pointer
16559: movl kvstn,4*exstm(r9)# remember stmnt number
16560: addl2 $4*excod,r9 # point to first code word
16561: movl r9,r3 # set code pointer
16562: cmpl stage,$stgxt # jump if not execution time
16563: beqlu 0f
16564: jmp exits
16565: 0:
16566: movl $stgee,stage # evaluating expression
16567: jmp exits # jump to execute first code word
16568: #page
16569: #
16570: # EVALX (CONTINUED)
16571: #
16572: # COME HERE IF SUCCESSFUL RETURN BY VALUE (SEE O$RVL)
16573: #
16574: evlx3: movl (sp)+,r9 # load value
16575: tstl 4*1(sp) # jump if called by value
16576: beqlu evlx5
16577: jmp er_249 # expression evaluated by name returned value
16578: #
16579: # HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM)
16580: #
16581: evlx4: movl (sp)+,r6 # load name offset
16582: movl (sp)+,r10 # load name base
16583: tstl 4*1(sp) # jump if called by name
16584: bnequ evlx5
16585: jsb acess # else access value first
16586: .long evlx6 # jump if failure during access
16587: #
16588: # HERE AFTER LOADING CORRECT RESULT INTO XR OR XL,WA
16589: #
16590: evlx5: clrl r7 # note successful
16591: jmp evlx7 # merge
16592: #
16593: # HERE FOR FAILURE IN EXPRESSION EVALUATION (SEE O$FEX)
16594: #
16595: evlx6: movl sp,r7 # note unsuccessful
16596: #
16597: # RESTORE ENVIRONMENT
16598: #
16599: evlx7: cmpl stage,$stgee # skip if was not previously xt
16600: bnequ evlx8
16601: movl $stgxt,stage # execute time
16602: #
16603: # MERGE WITH STAGE SET UP
16604: #
16605: evlx8: addl2 $4*num02,sp # pop name/value indicator, *exfal
16606: movl (sp)+,flptr # restore old failure pointer
16607: movl (sp)+,r8 # load code offset
16608: addl2 (sp),r8 # make code pointer absolute
16609: movl (sp)+,r$cod # restore old code block pointer
16610: movl r8,r3 # restore old code pointer
16611: tstl r7 # jump for successful return
16612: bnequ 0f
16613: jmp evlx1
16614: 0:
16615: #
16616: # MERGE HERE FOR FAILURE IN SEBLK CASE
16617: #
16618: evlx9: movl (sp)+,r11 # take failure exit
16619: jmp *(r11)+
16620: #enp # end of procedure evalx
16621: #page
16622: #
16623: # EXBLD -- BUILD EXBLK
16624: #
16625: # EXBLD IS USED TO BUILD AN EXPRESSION BLOCK FROM THE
16626: # CODE COMPILED MOST RECENTLY IN THE CURRENT CCBLK.
16627: #
16628: # (XL) OFFSET IN CCBLK TO START OF CODE
16629: # (WB) INTEGER IN RANGE 0 LE N LE MXLEN
16630: # JSR EXBLD CALL TO BUILD EXBLK
16631: # (XR) PTR TO CONSTRUCTED EXBLK
16632: # (WA,WB,XL) DESTROYED
16633: #
16634: exbld: #prc # entry point
16635: movl r10,r6 # copy offset to start of code
16636: subl2 $4*excod,r6 # calc reduction in offset in exblk
16637: movl r6,-(sp) # stack for later
16638: movl cwcof,r6 # load final offset
16639: subl2 r10,r6 # compute length of code
16640: addl2 $4*exsi$,r6 # add space for standard fields
16641: jsb alloc # allocate space for exblk
16642: movl r9,-(sp) # save pointer to exblk
16643: movl $b$exl,4*extyp(r9) # store type word
16644: clrl 4*exstm(r9) # zeroise stmnt number field
16645: movl r6,4*exlen(r9) # store length
16646: movl $ofex$,4*exflc(r9) # store failure word
16647: addl2 $4*exsi$,r9 # set xr for sysmw
16648: movl r10,cwcof # reset offset to start of code
16649: addl2 r$ccb,r10 # point to start of code
16650: subl2 $4*exsi$,r6 # length of code to move
16651: movl r6,-(sp) # stack length of code
16652: jsb sbmvw # move code to exblk
16653: movl (sp)+,r6 # get length of code
16654: ashl $-2,r6,r6 # convert byte count to word count
16655: # prepare counter for loop
16656: movl (sp),r10 # copy exblk ptr, dont unstack
16657: addl2 $4*excod,r10 # point to code itself
16658: movl 4*1(sp),r7 # get reduction in offset
16659: #
16660: # THIS LOOP SEARCHES FOR NEGATION AND SELECTION CODE SO
16661: # THAT THE OFFSETS COMPUTED WHILST CODE WAS IN CODE BLOCK
16662: # CAN BE TRANSFORMED TO REDUCED VALUES APPLICABLE IN AN
16663: # EXBLK.
16664: #
16665: exbl1: movl (r10)+,r9 # get next code word
16666: cmpl r9,$osla$ # jump if selection found
16667: beqlu exbl3
16668: cmpl r9,$onta$ # jump if negation found
16669: beqlu exbl3
16670: sobgtr r6,exbl1 # loop to end of code
16671: #
16672: # NO SELECTION FOUND OR MERGE TO EXIT ON TERMINATION
16673: #
16674: exbl2: movl (sp)+,r9 # pop exblk ptr into xr
16675: movl (sp)+,r10 # pop reduction constant
16676: rsb # return to caller
16677: #page
16678: #
16679: # EXBLD (CONTINUED)
16680: #
16681: # SELECTION OR NEGATION FOUND
16682: # REDUCE THE OFFSETS AS NEEDED. OFFSETS OCCUR IN WORDS
16683: # FOLLOWING CODE WORDS -
16684: # =ONTA$, =OSLA$, =OSLB$, =OSLC$
16685: #
16686: exbl3: subl2 r7,(r10)+ # adjust offset
16687: sobgtr r6,exbl4 # decrement count
16688: #
16689: exbl4: sobgtr r6,exbl5 # decrement count
16690: #
16691: # CONTINUE SEARCH FOR MORE OFFSETS
16692: #
16693: exbl5: movl (r10)+,r9 # get next code word
16694: cmpl r9,$osla$ # jump if offset found
16695: beqlu exbl3
16696: cmpl r9,$oslb$ # jump if offset found
16697: beqlu exbl3
16698: cmpl r9,$oslc$ # jump if offset found
16699: beqlu exbl3
16700: cmpl r9,$onta$ # jump if offset found
16701: beqlu exbl3
16702: sobgtr r6,exbl5 # loop
16703: jmp exbl2 # merge to return
16704: #enp # end procedure exbld
16705: #page
16706: #
16707: # EXPAN -- ANALYZE EXPRESSION
16708: #
16709: # THE EXPRESSION ANALYZER (EXPAN) PROCEDURE IS USED TO SCAN
16710: # AN EXPRESSION AND CONVERT IT INTO A TREE REPRESENTATION.
16711: # SEE DESCRIPTIONS OF CMBLK, CUBLK, CBBLK IN THE STRUCTURES
16712: # SECTION FOR DETAILED FORMAT OF TREE BLOCKS.
16713: #
16714: # THE ANALYZER USES A SIMPLE PRECEDENCE SCHEME IN WHICH
16715: # OPERANDS AND OPERATORS ARE PLACED ON A SINGLE STACK
16716: # AND CONDENSATIONS ARE MADE WHEN LOW PRECEDENCE OPERATORS
16717: # ARE STACKED AFTER A HIGHER PRECEDENCE OPERATOR. A GLOBAL
16718: # VARIABLE (IN WB) KEEPS TRACK OF THE LEVEL AS FOLLOWS.
16719: #
16720: # 0 SCANNING OUTER LEVEL OF STATEMENT OR EXPRESSION
16721: # 1 SCANNING OUTER LEVEL OF NORMAL GOTO
16722: # 2 SCANNING OUTER LEVEL OF DIRECT GOTO
16723: # 3 SCANNING INSIDE ARRAY BRACKETS
16724: # 4 SCANNING INSIDE GROUPING PARENTHESES
16725: # 5 SCANNING INSIDE FUNCTION PARENTHESES
16726: #
16727: # THIS VARIABLE IS SAVED ON THE STACK ON ENCOUNTERING A
16728: # GROUPING AND RESTORED AT THE END OF THE GROUPING.
16729: #
16730: # ANOTHER GLOBAL VARIABLE (IN WC) COUNTS THE NUMBER OF
16731: # ITEMS AT ONE GROUPING LEVEL AND IS INCREMENTED FOR EACH
16732: # COMMA ENCOUNTERED. IT IS STACKED WITH THE LEVEL INDICATOR
16733: #
16734: # THE SCAN IS CONTROLLED BY A THREE STATE FINITE MACHINE.
16735: # A GLOBAL VARIABLE STORED IN WA IS THE CURRENT STATE.
16736: #
16737: # WA=0 NOTHING SCANNED AT THIS LEVEL
16738: # WA=1 OPERAND EXPECTED
16739: # WA=2 OPERATOR EXPECTED
16740: #
16741: # (WB) CALL TYPE (SEE BELOW)
16742: # JSR EXPAN CALL TO ANALYZE EXPRESSION
16743: # (XR) POINTER TO RESULTING TREE
16744: # (XL,WA,WB,WC,RA) DESTROYED
16745: #
16746: # THE ENTRY VALUE OF WB INDICATES THE CALL TYPE AS FOLLOWS.
16747: #
16748: # 0 SCANNING EITHER THE MAIN BODY OF A STATEMENT OR THE
16749: # TEXT OF AN EXPRESSION (FROM EVAL CALL). VALID
16750: # TERMINATORS ARE COLON, SEMICOLON. THE RESCAN FLAG IS
16751: # SET TO RETURN THE TERMINATOR ON THE NEXT SCANE CALL.
16752: #
16753: # 1 SCANNING A NORMAL GOTO. THE ONLY VALID
16754: # TERMINATOR IS A RIGHT PAREN.
16755: #
16756: # 2 SCANNING A DIRECT GOTO. THE ONLY VALID
16757: # TERMINATOR IS A RIGHT BRACKET.
16758: #page
16759: #
16760: # EXPAN (CONTINUED)
16761: #
16762: # ENTRY POINT
16763: #
16764: expan: #prc # entry point
16765: clrl -(sp) # set top of stack indicator
16766: clrl r6 # set initial state to zero
16767: clrl r8 # zero counter value
16768: #
16769: # LOOP HERE FOR SUCCESSIVE ENTRIES
16770: #
16771: exp01: jsb scane # scan next element
16772: addl2 r6,r10 # add state to syntax code
16773: casel r10,$0,$t$nes # switch on element type/state
16774: 5:
16775: .word exp27-5b # unop, s=0
16776: .word exp27-5b # unop, s=1
16777: .word exp04-5b # unop, s=2
16778: .word exp06-5b # left paren, s=0
16779: .word exp06-5b # left paren, s=1
16780: .word exp04-5b # left paren, s=2
16781: .word exp08-5b # left brkt, s=0
16782: .word exp08-5b # left brkt, s=1
16783: .word exp09-5b # left brkt, s=2
16784: .word exp02-5b # comma, s=0
16785: .word exp05-5b # comma, s=1
16786: .word exp11-5b # comma, s=2
16787: .word exp10-5b # function, s=0
16788: .word exp10-5b # function, s=1
16789: .word exp04-5b # function, s=2
16790: .word exp03-5b # variable, s=0
16791: .word exp03-5b # variable, state one
16792: .word exp04-5b # variable, s=2
16793: .word exp03-5b # constant, s=0
16794: .word exp03-5b # constant, s=1
16795: .word exp04-5b # constant, s=2
16796: .word exp05-5b # binop, s=0
16797: .word exp05-5b # binop, s=1
16798: .word exp26-5b # binop, s=2
16799: .word exp02-5b # right paren, s=0
16800: .word exp05-5b # right paren, s=1
16801: .word exp12-5b # right paren, s=2
16802: .word exp02-5b # right brkt, s=0
16803: .word exp05-5b # right brkt, s=1
16804: .word exp18-5b # right brkt, s=2
16805: .word exp02-5b # colon, s=0
16806: .word exp05-5b # colon, s=1
16807: .word exp19-5b # colon, s=2
16808: .word exp02-5b # semicolon, s=0
16809: .word exp05-5b # semicolon, s=1
16810: .word exp19-5b # semicolon, s=2
16811: #esw # end switch on element type/state
16812: #page
16813: #
16814: # EXPAN (CONTINUED)
16815: #
16816: # HERE FOR RBR,RPR,COL,SMC,CMA IN STATE 0
16817: #
16818: # SET TO RESCAN THE TERMINATOR ENCOUNTERED AND CREATE
16819: # A NULL CONSTANT (CASE OF OMITTED NULL)
16820: #
16821: exp02: movl sp,scnrs # set to rescan element
16822: movl $nulls,r9 # point to null, merge
16823: #
16824: # HERE FOR VAR OR CON IN STATES 0,1
16825: #
16826: # STACK THE VARIABLE/CONSTANT AND SET STATE=2
16827: #
16828: exp03: movl r9,-(sp) # stack pointer to operand
16829: movl $num02,r6 # set state 2
16830: jmp exp01 # jump for next element
16831: #
16832: # HERE FOR VAR,CON,LPR,FNC,UOP IN STATE 2
16833: #
16834: # WE RESCAN THE ELEMENT AND CREATE A CONCATENATION OPERATOR
16835: # THIS IS THE CASE OF THE BLANK CONCATENATION OPERATOR.
16836: #
16837: exp04: movl sp,scnrs # set to rescan element
16838: movl $opdvc,r9 # point to concat operator dv
16839: tstl r7 # ok if at top level
16840: beqlu exp4a
16841: movl $opdvp,r9 # else point to unmistakable concat.
16842: #
16843: # MERGE HERE WHEN XR SET UP WITH PROPER CONCATENATION DVBLK
16844: #
16845: exp4a: tstl scnbl # merge bop if blanks, else error
16846: beqlu 0f
16847: jmp exp26
16848: 0:
16849: decl scnse # adjust start of element location
16850: jmp er_220 # syntax error. missing operator
16851: #
16852: # HERE FOR CMA,RPR,RBR,COL,SMC,BOP(S=1) BOP(S=0)
16853: #
16854: # THIS IS AN ERRONOUS CONTRUCTION
16855: #
16856: exp05: decl scnse # adjust start of element location
16857: jmp er_221 # syntax error. missing operand
16858: #
16859: # HERE FOR LPR (S=0,1)
16860: #
16861: exp06: movl $num04,r10 # set new level indicator
16862: clrl r9 # set zero value for cmopn
16863: #page
16864: #
16865: # EXPAN (CONTINUED)
16866: #
16867: # MERGE HERE TO STORE OLD LEVEL ON STACK AND START NEW ONE
16868: #
16869: exp07: movl r9,-(sp) # stack cmopn value
16870: movl r8,-(sp) # stack old counter
16871: movl r7,-(sp) # stack old level indicator
16872: jsb sbchk # check for stack overflow
16873: clrl r6 # set new state to zero
16874: movl r10,r7 # set new level indicator
16875: movl $num01,r8 # initialize new counter
16876: jmp exp01 # jump to scan next element
16877: #
16878: # HERE FOR LBR (S=0,1)
16879: #
16880: # THIS IS AN ILLEGAL USE OF LEFT BRACKET
16881: #
16882: exp08: jmp er_222 # syntax error. invalid use of left bracket
16883: #
16884: # HERE FOR LBR (S=2)
16885: #
16886: # SET NEW LEVEL AND START TO SCAN SUBSCRIPTS
16887: #
16888: exp09: movl (sp)+,r9 # load array ptr for cmopn
16889: movl $num03,r10 # set new level indicator
16890: jmp exp07 # jump to stack old and start new
16891: #
16892: # HERE FOR FNC (S=0,1)
16893: #
16894: # STACK OLD LEVEL AND START TO SCAN ARGUMENTS
16895: #
16896: exp10: movl $num05,r10 # set new lev indic (xr=vrblk=cmopn)
16897: jmp exp07 # jump to stack old and start new
16898: #
16899: # HERE FOR CMA (S=2)
16900: #
16901: # INCREMENT ARGUMENT COUNT AND CONTINUE
16902: #
16903: exp11: incl r8 # increment counter
16904: jsb expdm # dump operators at this level
16905: clrl -(sp) # set new level for parameter
16906: clrl r6 # set new state
16907: cmpl r7,$num02 # loop back unless outer level
16908: blequ 0f
16909: jmp exp01
16910: 0:
16911: jmp er_223 # syntax error. invalid use of comma
16912: #page
16913: #
16914: # EXPAN (CONTINUED)
16915: #
16916: # HERE FOR RPR (S=2)
16917: #
16918: # AT OUTER LEVEL IN A NORMAL GOTO THIS IS A TERMINATOR
16919: # OTHERWISE IT MUST TERMINATE A FUNCTION OR GROUPING
16920: #
16921: exp12: cmpl r7,$num01 # end of normal goto
16922: bnequ 0f
16923: jmp exp20
16924: 0:
16925: cmpl r7,$num05 # end of function arguments
16926: beqlu exp13
16927: cmpl r7,$num04 # end of grouping / selection
16928: beqlu exp14
16929: jmp er_224 # syntax error. unbalanced right parenthesis
16930: #
16931: # HERE AT END OF FUNCTION ARGUMENTS
16932: #
16933: exp13: movl $c$fnc,r10 # set cmtyp value for function
16934: jmp exp15 # jump to build cmblk
16935: #
16936: # HERE FOR END OF GROUPING
16937: #
16938: exp14: cmpl r8,$num01 # jump if end of grouping
16939: beqlu exp17
16940: movl $c$sel,r10 # else set cmtyp for selection
16941: #
16942: # MERGE HERE TO BUILD CMBLK FOR LEVEL JUST SCANNED AND
16943: # TO POP UP TO THE PREVIOUS SCAN LEVEL BEFORE CONTINUING.
16944: #
16945: exp15: jsb expdm # dump operators at this level
16946: movl r8,r6 # copy count
16947: addl2 $cmvls,r6 # add for standard fields at start
16948: moval 0[r6],r6 # convert length to bytes
16949: jsb alloc # allocate space for cmblk
16950: movl $b$cmt,(r9) # store type code for cmblk
16951: movl r10,4*cmtyp(r9) # store cmblk node type indicator
16952: movl r6,4*cmlen(r9) # store length
16953: addl2 r6,r9 # point past end of block
16954: # set loop counter
16955: #
16956: # LOOP TO MOVE REMAINING WORDS TO CMBLK
16957: #
16958: exp16: movl (sp)+,-(r9) # move one operand ptr from stack
16959: movl (sp)+,r7 # pop to old level indicator
16960: sobgtr r8,exp16 # loop till all moved
16961: #page
16962: #
16963: # EXPAN (CONTINUED)
16964: #
16965: # COMPLETE CMBLK AND STACK POINTER TO IT ON STACK
16966: #
16967: subl2 $4*cmvls,r9 # point back to start of block
16968: movl (sp)+,r8 # restore old counter
16969: movl (sp),4*cmopn(r9)# store operand ptr in cmblk
16970: movl r9,(sp) # stack cmblk pointer
16971: movl $num02,r6 # set new state
16972: jmp exp01 # back for next element
16973: #
16974: # HERE AT END OF A PARENTHESIZED EXPRESSION
16975: #
16976: exp17: jsb expdm # dump operators at this level
16977: movl (sp)+,r9 # restore xr
16978: movl (sp)+,r7 # restore outer level
16979: movl (sp)+,r8 # restore outer count
16980: movl r9,(sp) # store opnd over unused cmopn val
16981: movl $num02,r6 # set new state
16982: jmp exp01 # back for next ele8ent
16983: #
16984: # HERE FOR RBR (S=2)
16985: #
16986: # AT OUTER LEVEL IN A DIRECT GOTO, THIS IS A TERMINATOR.
16987: # OTHERWISE IT MUST TERMINATE A SUBSCRIPT LIST.
16988: #
16989: exp18: movl $c$arr,r10 # set cmtyp for array reference
16990: cmpl r7,$num03 # jump to build cmblk if end arrayref
16991: beqlu exp15
16992: cmpl r7,$num02 # jump if end of direct goto
16993: bnequ 0f
16994: jmp exp20
16995: 0:
16996: jmp er_225 # syntax error. unbalanced right bracket
16997: #page
16998: #
16999: # EXPAN (CONTINUED)
17000: #
17001: # HERE FOR COL,SMC (S=2)
17002: #
17003: # ERROR UNLESS TERMINATING STATEMENT BODY AT OUTER LEVEL
17004: #
17005: exp19: movl sp,scnrs # rescan terminator
17006: movl r7,r10 # copy level indicator
17007: casel r10,$0,$6 # switch on level indicator
17008: 5:
17009: .word exp20-5b # normal outer level
17010: .word exp22-5b # fail if normal goto
17011: .word exp23-5b # fail if direct goto
17012: .word exp24-5b # fail array brackets
17013: .word exp21-5b # fail if in grouping
17014: .word exp21-5b # fail function args
17015: #esw # end switch on level
17016: #
17017: # HERE AT NORMAL END OF EXPRESSION
17018: #
17019: exp20: jsb expdm # dump remaining operators
17020: movl (sp)+,r9 # load tree pointer
17021: addl2 $4,sp # pop off bottom of stack marker
17022: rsb # return to expan caller
17023: #
17024: # MISSING RIGHT PAREN
17025: #
17026: exp21: jmp er_226 # syntax error. missing right paren
17027: #
17028: # MISSING RIGHT PAREN IN GOTO FIELD
17029: #
17030: exp22: jmp er_227 # syntax error. right paren missing from goto
17031: #
17032: # MISSING BRACKET IN GOTO
17033: #
17034: exp23: jmp er_228 # syntax error. right bracket missing from goto
17035: #
17036: # MISSING ARRAY BRACKET
17037: #
17038: exp24: jmp er_229 # syntax error. missing right array bracket
17039: #page
17040: #
17041: # EXPAN (CONTINUED)
17042: #
17043: # LOOP HERE WHEN AN OPERATOR CAUSES AN OPERATOR DUMP
17044: #
17045: exp25: movl r9,expsv
17046: jsb expop # pop one operator
17047: movl expsv,r9 # restore op dv pointer and merge
17048: #
17049: # HERE FOR BOP (S=2)
17050: #
17051: # REMOVE OPERATORS (CONDENSE) FROM STACK UNTIL NO MORE
17052: # LEFT AT THIS LEVEL OR TOP ONE HAS LOWER PRECEDENCE.
17053: # LOOP HERE TILL THIS CONDITION IS MET.
17054: #
17055: exp26: movl 4*1(sp),r10 # load operator dvptr from stack
17056: cmpl r10,$num05 # jump if bottom of stack level
17057: blequ exp27
17058: cmpl 4*dvrpr(r9),4*dvlpr(r10) # else pop if new prec is lo
17059: blssu exp25
17060: #
17061: # HERE FOR UOP (S=0,1)
17062: #
17063: # BINARY OPERATOR MERGES AFTER PRECEDENCE CHECK
17064: #
17065: # THE OPERATOR DV IS STORED ON THE STACK AND THE SCAN
17066: # CONTINUES AFTER SETTING THE SCAN STATE TO ONE.
17067: #
17068: exp27: movl r9,-(sp) # stack operator dvptr on stack
17069: jsb sbchk # check for stack overflow
17070: movl $num01,r6 # set new state
17071: cmpl r9,$opdvs # back for next element unless =
17072: beqlu 0f
17073: jmp exp01
17074: 0:
17075: #
17076: # HERE FOR SPECIAL CASE OF BINARY =. THE SYNTAX ALLOWS A
17077: # NULL RIGHT ARGUMENT FOR THIS OPERATOR TO BE LEFT
17078: # OUT. ACCORDINGLY WE RESET TO STATE ZERO TO GET PROPER
17079: # ACTION ON A TERMINATOR (SUPPLY A NULL CONSTANT).
17080: #
17081: clrl r6 # set state zero
17082: jmp exp01 # jump for next element
17083: #enp # end procedure expan
17084: #page
17085: #
17086: # EXPAP -- TEST FOR PATTERN MATCH TREE
17087: #
17088: # EXPAP IS PASSED AN EXPRESSION TREE TO DETERMINE IF IT
17089: # IS A PATTERN MATCH. THE FOLLOWING ARE RECOGIZED AS
17090: # MATCHES IN THE CONTEXT OF THIS CALL.
17091: #
17092: # 1) AN EXPLICIT USE OF BINARY QUESTION MARK
17093: # 2) A CONCATENATION
17094: # 3) AN ALTERNATION WHOSE LEFT OPERAND IS A CONCATENATION
17095: #
17096: # (XR) PTR TO EXPAN TREE
17097: # JSR EXPAP CALL TO TEST FOR PATTERN MATCH
17098: # PPM LOC TRANSFER LOC IF NOT A PATTERN MATCH
17099: # (WA) DESTROYED
17100: # (XR) UNCHANGED (IF NOT MATCH)
17101: # (XR) PTR TO BINARY OPERATOR BLK IF MATCH
17102: #
17103: expap: #prc # entry point
17104: movl r10,-(sp) # save xl
17105: cmpl (r9),$b$cmt # no match if not complex
17106: bnequ expp2
17107: movl 4*cmtyp(r9),r6 # else load type code
17108: cmpl r6,$c$cnc # concatenation is a match
17109: beqlu expp1
17110: cmpl r6,$c$pmt # binary question mark is a match
17111: beqlu expp1
17112: cmpl r6,$c$alt # else not match unless alternation
17113: bnequ expp2
17114: #
17115: # HERE FOR ALTERNATION. CHANGE (A B) / C TO A QM (B / C)
17116: #
17117: movl 4*cmlop(r9),r10 # load left operand pointer
17118: cmpl (r10),$b$cmt # not match if left opnd not complex
17119: bnequ expp2
17120: cmpl 4*cmtyp(r10),$c$cnc # not match if left op not conc
17121: bnequ expp2
17122: movl 4*cmrop(r10),4*cmlop(r9) # xr points to (b / c)
17123: movl r9,4*cmrop(r10) # set xl opnds to a, (b / c)
17124: movl r10,r9 # point to this altered node
17125: #
17126: # EXIT HERE FOR PATTERN MATCH
17127: #
17128: expp1: movl (sp)+,r10 # restore entry xl
17129: addl2 $4*1,(sp) # give pattern match return
17130: rsb
17131: #
17132: # EXIT HERE IF NOT PATTERN MATCH
17133: #
17134: expp2: movl (sp)+,r10 # restore entry xl
17135: movl (sp)+,r11 # give non-match return
17136: jmp *(r11)+
17137: #enp # end procedure expap
17138: #page
17139: #
17140: # EXPDM -- DUMP OPERATORS AT CURRENT LEVEL (FOR EXPAN)
17141: #
17142: # EXPDM USES EXPOP TO CONDENSE ALL OPERATORS AT THIS SYNTAX
17143: # LEVEL. THE STACK BOTTOM IS RECOGNIZED FROM THE LEVEL
17144: # VALUE WHICH IS SAVED ON THE TOP OF THE STACK.
17145: #
17146: # JSR EXPDM CALL TO DUMP OPERATORS
17147: # (XS) POPPED AS REQUIRED
17148: # (XR,WA) DESTROYED
17149: #
17150: .data 1
17151: expdm_s: .long 0
17152: .text 0
17153: expdm: movl (sp)+,expdm_s # entry point
17154: movl r10,r$exs # save xl value
17155: #
17156: # LOOP TO DUMP OPERATORS
17157: #
17158: exdm1: cmpl 4*1(sp),$num05 # jump if stack bottom (saved level
17159: blequ exdm2
17160: jsb expop # else pop one operator
17161: jmp exdm1 # and loop back
17162: #
17163: # HERE AFTER POPPING ALL OPERATORS
17164: #
17165: exdm2: movl r$exs,r10 # restore xl
17166: clrl r$exs # release save location
17167: jmp *expdm_s # return to expdm caller
17168: #enp # end procedure expdm
17169: #page
17170: #
17171: # EXPOP-- POP OPERATOR (FOR EXPAN)
17172: #
17173: # EXPOP IS USED BY THE EXPAN ROUTINE TO CONDENSE ONE
17174: # OPERATOR FROM THE TOP OF THE SYNTAX STACK. AN APPROPRIATE
17175: # CMBLK IS BUILT FOR THE OPERATOR (UNARY OR BINARY) AND A
17176: # POINTER TO THIS CMBLK IS STACKED.
17177: #
17178: # EXPOP IS ALSO USED BY SCNGF (GOTO FIELD SCAN) PROCEDURE
17179: #
17180: # JSR EXPOP CALL TO POP OPERATOR
17181: # (XS) POPPED APPROPRIATELY
17182: # (XR,XL,WA) DESTROYED
17183: #
17184: .data 1
17185: expop_s: .long 0
17186: .text 0
17187: expop: movl (sp)+,expop_s # entry point
17188: movl 4*1(sp),r9 # load operator dv pointer
17189: cmpl 4*dvlpr(r9),$lluno # jump if unary
17190: beqlu expo2
17191: #
17192: # HERE FOR BINARY OPERATOR
17193: #
17194: movl $4*cmbs$,r6 # set size of binary operator cmblk
17195: jsb alloc # allocate space for cmblk
17196: movl (sp)+,4*cmrop(r9)# pop and store right operand ptr
17197: movl (sp)+,r10 # pop and load operator dv ptr
17198: movl (sp),4*cmlop(r9)# store left operand pointer
17199: #
17200: # COMMON EXIT POINT
17201: #
17202: expo1: movl $b$cmt,(r9) # store type code for cmblk
17203: movl 4*dvtyp(r10),4*cmtyp(r9) # store cmblk node type code
17204: movl r10,4*cmopn(r9) # store dvptr (=ptr to dac o$xxx)
17205: movl r6,4*cmlen(r9) # store cmblk length
17206: movl r9,(sp) # store resulting node ptr on stack
17207: jmp *expop_s # return to expop caller
17208: #
17209: # HERE FOR UNARY OPERATOR
17210: #
17211: expo2: movl $4*cmus$,r6 # set size of unary operator cmblk
17212: jsb alloc # allocate space for cmblk
17213: movl (sp)+,4*cmrop(r9)# pop and store operand pointer
17214: movl (sp),r10 # load operator dv pointer
17215: jmp expo1 # merge back to exit
17216: #enp # end procedure expop
17217: #page
17218: #
17219: # FLSTG -- FOLD STRING TO UPPER CASE
17220: #
17221: # FLSTG FOLDS A CHARACTER STRING CONTAINING LOWER CASE
17222: # CHARACCTERS TO ONE CONTAINING UPPER CASE CHARACTERS.
17223: # FOLDING IS ONLY DONE IF &CASE (KVCAS) IS NOT ZERO.
17224: #
17225: # (XR) STRING ARGUMENT
17226: # (WA) LENGTH OF STRING
17227: # JSR FLSTG CALL TO FOLD STRING
17228: # (XR) RESULT STRING (POSSIBLY ORIGINAL)
17229: # (WC) DESTROYED
17230: #
17231: flstg: #prc # entry point
17232: tstl kvcas # skip if &case is 0
17233: beqlu fst99
17234: movl r10,-(sp) # save xl across call
17235: movl r9,-(sp) # save original scblk ptr
17236: jsb alocs # allocate new string block
17237: movl (sp),r10 # point to original scblk
17238: movl r9,-(sp) # save pointer to new scblk
17239: movab cfp$f(r10),r10 # point to original chars
17240: movab cfp$f(r9),r9 # point to new chars
17241: clrl -(sp) # init did fold flag
17242: # load loop counter
17243: fst01: movzbl (r10)+,r6 # load character
17244: cmpl $ch$$a,r6 # skip if less than lc a
17245: bgtru fst02
17246: cmpl r6,$ch$$$ # skip if greater than lc z
17247: bgtru fst02
17248: bicl2 $ch$bl,r6 # fold character to upper case
17249: movl sp,(sp) # set did fold character flag
17250: fst02: movb r6,(r9)+ # store (possibly folded) character
17251: sobgtr r8,fst01 # loop thru entire string
17252: #csc r9 # complete store characters
17253: tstl (sp)+ # skip if folding done
17254: bnequ fst10
17255: movl (sp)+,dnamp # do not need new scblk
17256: movl (sp)+,r9 # return original scblk
17257: jmp fst20 # merge below
17258: fst10: movl (sp)+,r9 # return new scblk
17259: addl2 $4,sp # throw away original scblk pointer
17260: fst20: movl 4*sclen(r9),r6 # reload string length
17261: movl (sp)+,r10 # restore xl
17262: fst99: rsb # return
17263: #enp
17264: #page
17265: #
17266: # GBCOL -- PERFORM GARBAGE COLLECTION
17267: #
17268: # GBCOL PERFORMS A GARBAGE COLLECTION ON THE DYNAMIC REGION
17269: # ALL BLOCKS WHICH ARE NO LONGER IN USE ARE ELIMINATED
17270: # BY MOVING BLOCKS WHICH ARE IN USE DOWN AND RESETTING
17271: # DNAMP, THE POINTER TO THE NEXT AVAILABLE LOCATION.
17272: #
17273: # (WB) MOVE OFFSET (SEE BELOW)
17274: # JSR GBCOL CALL TO COLLECT GARBAGE
17275: # (XR) DESTROYED
17276: #
17277: # THE FOLLOWING CONDITIONS MUST BE MET AT THE TIME WHEN
17278: # GBCOL IS CALLED.
17279: #
17280: # 1) ALL POINTERS TO BLOCKS IN THE DYNAMIC AREA MUST BE
17281: # ACCESSIBLE TO THE GARBAGE COLLECTOR. THIS MEANS
17282: # THAT THEY MUST OCCUR IN ONE OF THE FOLLOWING.
17283: #
17284: # A) MAIN STACK, WITH CURRENT TOP
17285: # ELEMENT BEING INDICATED BY XS
17286: #
17287: # B) IN RELOCATABLE FIELDS OF VRBLKS.
17288: #
17289: # C) IN REGISTER XL AT THE TIME OF CALL
17290: #
17291: # E) IN THE SPECIAL REGION OF WORKING
17292: # STORAGE WHERE NAMES BEGIN WITH R$.
17293: #
17294: # 2) ALL POINTERS MUST POINT TO THE START OF BLOCKS WITH
17295: # THE SOLE EXCEPTION OF THE CONTENTS OF THE CODE
17296: # POINTER REGISTER WHICH POINTS INTO THE R$COD BLOCK.
17297: #
17298: # 3) NO LOCATION WHICH APPEARS TO CONTAIN A POINTER
17299: # INTO THE DYNAMIC REGION MAY OCCUR UNLESS IT IS IN
17300: # FACT A POINTER TO THE START OF THE BLOCK. HOWEVER
17301: # POINTERS OUTSIDE THIS AREA MAY OCCUR AND WILL
17302: # NOT BE CHANGED BY THE GARBAGE COLLECTOR.
17303: # IT IS ESPECIALLY IMPORTANT TO MAKE SURE THAT XL
17304: # DOES NOT CONTAIN A GARBAGE VALUE FROM SOME PROCESS
17305: # CARRIED OUT BEFORE THE CALL TO THE COLLECTOR.
17306: #
17307: # GBCOL HAS THE CAPABILITY OF MOVING THE FINAL COMPACTED
17308: # RESULT UP IN MEMORY (WITH ADDRESSES ADJUSTED ACCORDINGLY)
17309: # THIS IS USED TO ADD SPACE TO THE STATIC REGION. THE
17310: # ENTRY VALUE OF WB IS THE NUMBER OF BYTES TO MOVE UP.
17311: # THE CALLER MUST GUARANTEE THAT THERE IS ENOUGH ROOM.
17312: # FURTHERMORE THE VALUE IN WB IF IT IS NON-ZERO, MUST BE AT
17313: # LEAST 256 SO THAT THE MWB INSTRUCTION CONDITIONS ARE MET.
17314: #page
17315: #
17316: # GBCOL (CONTINUED)
17317: #
17318: # THE ALGORITHM, WHICH IS A MODIFICATION OF THE LISP-2
17319: # GARBAGE COLLECTOR DEVISED BY R.DEWAR AND K.BELCHER
17320: # TAKES THREE PASSES AS FOLLOWS.
17321: #
17322: # 1) ALL POINTERS IN MEMORY ARE SCANNED AND BLOCKS IN USE
17323: # DETERMINED FROM THIS SCAN. NOTE THAT THIS PROCEDURE
17324: # IS RECURSIVE AND USES THE MAIN STACK FOR LINKAGE.
17325: # THE MARKING PROCESS IS THUS SIMILAR TO THAT USED IN
17326: # A STANDARD LISP COLLECTOR. HOWEVER THE METHOD OF
17327: # ACTUALLY MARKING THE BLOCKS IS DIFFERENT.
17328: #
17329: # THE FIRST FIELD OF A BLOCK NORMALLY CONTAINS A
17330: # CODE ENTRY POINT POINTER. SUCH AN ENTRY POINTER
17331: # CAN BE DISTINGUISHED FROM THE ADDRESS OF ANY POINTER
17332: # TO BE PROCESSED BY THE COLLECTOR. DURING GARBAGE
17333: # COLLECTION, THIS WORD IS USED TO BUILD A BACK CHAIN
17334: # OF POINTERS THROUGH FIELDS WHICH POINT TO THE BLOCK.
17335: # THE END OF THE CHAIN IS MARKED BY THE OCCURENCE
17336: # OF THE WORD WHICH USED TO BE IN THE FIRST WORD OF
17337: # THE BLOCK. THIS BACKCHAIN SERVES BOTH AS A MARK
17338: # INDICATING THAT THE BLOCK IS IN USE AND AS A LIST OF
17339: # REFERENCES FOR THE RELOCATION PHASE.
17340: #
17341: # 2) STORAGE IS SCANNED SEQUENTIALLY TO DISCOVER WHICH
17342: # BLOCKS ARE CURRENTLY IN USE AS INDICATED BY THE
17343: # PRESENCE OF A BACKCHAIN. TWO POINTERS ARE MAINTAINED
17344: # ONE SCANS THROUGH LOOKING AT EACH BLOCK. THE OTHER
17345: # IS INCREMENTED ONLY FOR BLOCKS FOUND TO BE IN USE.
17346: # IN THIS WAY, THE EVENTUAL LOCATION OF EACH BLOCK CAN
17347: # BE DETERMINED WITHOUT ACTUALLY MOVING ANY BLOCKS.
17348: # AS EACH BLOCK WHICH IS IN USE IS PROCESSED, THE BACK
17349: # CHAIN IS USED TO RESET ALL POINTERS WHICH POINT TO
17350: # THIS BLOCK TO CONTAIN ITS NEW ADDRESS, I.E. THE
17351: # ADDRESS IT WILL OCCUPY AFTER THE BLOCKS ARE MOVED.
17352: # THE FIRST WORD OF THE BLOCK, TAKEN FROM THE END OF
17353: # THE CHAIN IS RESTORED AT THIS POINT.
17354: #
17355: # DURING PASS 2, THE COLLECTOR BUILDS BLOCKS WHICH
17356: # DESCRIBE THE REGIONS OF STORAGE WHICH ARE TO BE
17357: # MOVED IN THE THIRD PASS. THERE IS ONE DESCRIPTOR FOR
17358: # EACH CONTIGUOUS SET OF GOOD BLOCKS. THE DESCRIPTOR
17359: # IS BUILT JUST BEHIND THE BLOCK TO BE MOVED AND
17360: # CONTAINS A POINTER TO THE NEXT BLOCK AND THE NUMBER
17361: # OF WORDS TO BE MOVED.
17362: #
17363: # 3) IN THE THIRD AND FINAL PASS, THE MOVE DESCRIPTOR
17364: # BLOCKS BUILT IN PASS TWO ARE USED TO ACTUALLY MOVE
17365: # THE BLOCKS DOWN TO THE BOTTOM OF THE DYNAMIC REGION.
17366: # THE COLLECTION IS THEN COMPLETE AND THE NEXT
17367: # AVAILABLE LOCATION POINTER IS RESET.
17368: #page
17369: #
17370: # GBCOL (CONTINUED)
17371: #
17372: gbcol: #prc # entry point
17373: tstl dmvch # fail if in mid-dump
17374: beqlu 0f
17375: jmp gbc14
17376: 0:
17377: movl sp,gbcfl # note gbcol entered
17378: movl r6,gbsva # save entry wa
17379: movl r7,gbsvb # save entry wb
17380: movl r8,gbsvc # save entry wc
17381: movl r10,-(sp) # save entry xl
17382: movl r3,r6 # get code pointer value
17383: subl2 r$cod,r6 # make relative
17384: movl r6,r3 # and restore
17385: #
17386: # PROCESS STACK ENTRIES
17387: #
17388: movl sp,r9 # point to stack front
17389: movl stbas,r10 # point past end of stack
17390: cmpl r10,r9 # ok if d-stack
17391: bgequ gbc00
17392: movl r10,r9 # reverse if ...
17393: movl sp,r10 # ... u-stack
17394: #
17395: # PROCESS THE STACK
17396: #
17397: gbc00: jsb gbcpf # process pointers on stack
17398: #
17399: # PROCESS SPECIAL WORK LOCATIONS
17400: #
17401: movl $r$aaa,r9 # point to start of relocatable locs
17402: movl $r$yyy,r10 # point past end of relocatable locs
17403: jsb gbcpf # process work fields
17404: #
17405: # PREPARE TO PROCESS VARIABLE BLOCKS
17406: #
17407: movl hshtb,r6 # point to first hash slot pointer
17408: #
17409: # LOOP THROUGH HASH SLOTS
17410: #
17411: gbc01: movl r6,r10 # point to next slot
17412: addl2 $4,r6 # bump bucket pointer
17413: movl r6,gbcnm # save bucket pointer
17414: #page
17415: #
17416: # GBCOL (CONTINUED)
17417: #
17418: # LOOP THROUGH VARIABLES ON ONE HASH CHAIN
17419: #
17420: gbc02: movl (r10),r9 # load ptr to next vrblk
17421: tstl r9 # jump if end of chain
17422: beqlu gbc03
17423: movl r9,r10 # else copy vrblk pointer
17424: addl2 $4*vrval,r9 # point to first reloc fld
17425: addl2 $4*vrnxt,r10 # point past last (and to link ptr)
17426: jsb gbcpf # process reloc fields in vrblk
17427: jmp gbc02 # loop back for next block
17428: #
17429: # HERE AT END OF ONE HASH CHAIN
17430: #
17431: gbc03: movl gbcnm,r6 # restore bucket pointer
17432: cmpl r6,hshte # loop back if more buckets to go
17433: bnequ gbc01
17434: #page
17435: #
17436: # GBCOL (CONTINUED)
17437: #
17438: # NOW WE ARE READY TO START PASS TWO. REGISTERS ARE USED
17439: # AS FOLLOWS IN PASS TWO.
17440: #
17441: # (XR) SCANS THROUGH ALL BLOCKS
17442: # (WC) POINTER TO EVENTUAL LOCATION
17443: #
17444: # THE MOVE DESCRIPTION BLOCKS BUILT IN THIS PASS HAVE
17445: # THE FOLLOWING FORMAT.
17446: #
17447: # WORD 1 POINTER TO NEXT MOVE BLOCK,
17448: # ZERO IF END OF CHAIN OF BLOCKS
17449: #
17450: # WORD 2 LENGTH OF BLOCKS TO BE MOVED IN
17451: # BYTES. SET TO THE ADDRESS OF THE
17452: # FIRST BYTE WHILE ACTUALLY SCANNING
17453: # THE BLOCKS.
17454: #
17455: # THE FIRST ENTRY ON THIS CHAIN IS A SPECIAL ENTRY
17456: # CONSISTING OF THE TWO WORDS GBCNM AND GBCNS. AFTER
17457: # BUILDING THE CHAIN OF MOVE DESCRIPTORS, GBCNM POINTS TO
17458: # THE FIRST REAL MOVE BLOCK, AND GBCNS IS THE LENGTH OF
17459: # BLOCKS IN USE AT THE START OF STORAGE WHICH NEED NOT
17460: # BE MOVED SINCE THEY ARE IN THE CORRECT POSITION.
17461: #
17462: gbc04: movl dnamb,r9 # point to first block
17463: movl r9,r8 # set as first eventual location
17464: addl2 gbsvb,r8 # add offset for eventual move up
17465: clrl gbcnm # clear initial forward pointer
17466: movl $gbcnm,gbclm # initialize ptr to last move block
17467: movl r9,gbcns # initialize first address
17468: #
17469: # LOOP THROUGH A SERIES OF BLOCKS IN USE
17470: #
17471: gbc05: cmpl r9,dnamp # jump if end of used region
17472: beqlu gbc07
17473: movl (r9),r6 # else get first word
17474: cmpl r6,$p$yyy # skip if not entry ptr (in use)
17475: bgequ gbc06
17476: cmpl r6,$b$aaa # jump if entry pointer (unused)
17477: bgequ gbc07
17478: #
17479: # HERE FOR BLOCK IN USE, LOOP TO RELOCATE REFERENCES
17480: #
17481: gbc06: movl r6,r10 # copy pointer
17482: movl (r10),r6 # load forward pointer
17483: movl r8,(r10) # relocate reference
17484: cmpl r6,$p$yyy # loop back if not end of chain
17485: bgequ gbc06
17486: cmpl r6,$b$aaa # loop back if not end of chain
17487: blequ gbc06
17488: #page
17489: #
17490: # GBCOL (CONTINUED)
17491: #
17492: # AT END OF CHAIN, RESTORE FIRST WORD AND BUMP PAST
17493: #
17494: movl r6,(r9) # restore first word
17495: jsb blkln # get length of this block
17496: addl2 r6,r9 # bump actual pointer
17497: addl2 r6,r8 # bump eventual pointer
17498: jmp gbc05 # loop back for next block
17499: #
17500: # HERE AT END OF A SERIES OF BLOCKS IN USE
17501: #
17502: gbc07: movl r9,r6 # copy pointer past last block
17503: movl gbclm,r10 # point to previous move block
17504: subl2 4*1(r10),r6 # subtract starting address
17505: movl r6,4*1(r10) # store length of block to be moved
17506: #
17507: # LOOP THROUGH A SERIES OF BLOCKS NOT IN USE
17508: #
17509: gbc08: cmpl r9,dnamp # jump if end of used region
17510: beqlu gbc10
17511: movl (r9),r6 # else load first word of next block
17512: cmpl r6,$p$yyy # jump if in use
17513: bgequ gbc09
17514: cmpl r6,$b$aaa # jump if in use
17515: blequ gbc09
17516: jsb blkln # else get length of next block
17517: addl2 r6,r9 # push pointer
17518: jmp gbc08 # and loop back
17519: #
17520: # HERE FOR A BLOCK IN USE AFTER PROCESSING A SERIES OF
17521: # BLOCKS WHICH WERE NOT IN USE, BUILD NEW MOVE BLOCK.
17522: #
17523: gbc09: subl2 $4*num02,r9 # point 2 words behind for move block
17524: movl gbclm,r10 # point to previous move block
17525: movl r9,(r10) # set forward ptr in previous block
17526: clrl (r9) # zero forward ptr of new block
17527: movl r9,gbclm # remember address of this block
17528: movl r9,r10 # copy ptr to move block
17529: addl2 $4*num02,r9 # point back to block in use
17530: movl r9,4*1(r10) # store starting address
17531: jmp gbc06 # jump to process block in use
17532: #page
17533: #
17534: # GBCOL (CONTINUED)
17535: #
17536: # HERE FOR PASS THREE -- ACTUALLY MOVE THE BLOCKS DOWN
17537: #
17538: # (XL) POINTER TO OLD LOCATION
17539: # (XR) POINTER TO NEW LOCATION
17540: #
17541: gbc10: movl dnamb,r9 # point to start of storage
17542: addl2 gbcns,r9 # bump past unmoved blocks at start
17543: #
17544: # LOOP THROUGH MOVE DESCRIPTORS
17545: #
17546: gbc11: movl gbcnm,r10 # point to next move block
17547: tstl r10 # jump if end of chain
17548: beqlu gbc12
17549: movl (r10)+,gbcnm # move pointer down chain
17550: movl (r10)+,r6 # get length to move
17551: jsb sbmvw # perform move
17552: jmp gbc11 # loop back
17553: #
17554: # NOW TEST FOR MOVE UP
17555: #
17556: gbc12: movl r9,dnamp # set next available loc ptr
17557: movl gbsvb,r7 # reload move offset
17558: tstl r7 # jump if no move required
17559: beqlu gbc13
17560: movl r9,r10 # else copy old top of core
17561: addl2 r7,r9 # point to new top of core
17562: movl r9,dnamp # save new top of core pointer
17563: movl r10,r6 # copy old top
17564: subl2 dnamb,r6 # minus old bottom = length
17565: addl2 r7,dnamb # bump bottom to get new value
17566: jsb sbmwb # perform move (backwards)
17567: #
17568: # MERGE HERE TO EXIT
17569: #
17570: gbc13: movl gbsva,r6 # restore wa
17571: movl r3,r8 # get code pointer
17572: addl2 r$cod,r8 # make absolute again
17573: movl r8,r3 # and replace absolute value
17574: movl gbsvc,r8 # restore wc
17575: movl (sp)+,r10 # restore entry xl
17576: incl gbcnt # increment count of collections
17577: clrl r9 # clear garbage value in xr
17578: clrl gbcfl # note exit from gbcol
17579: rsb # exit to gbcol caller
17580: #
17581: # GARBAGE COLLECTION NOT ALLOWED WHILST DUMPING
17582: #
17583: gbc14: incl errft # fatal error
17584: jmp er_250 # insufficient memory to complete dump
17585: #enp # end procedure gbcol
17586: #page
17587: #
17588: # GBCPF -- PROCESS FIELDS FOR GARBAGE COLLECTOR
17589: #
17590: # THIS PROCEDURE IS USED BY THE GARBAGE COLLECTOR TO
17591: # PROCESS FIELDS IN PASS ONE. SEE GBCOL FOR FULL DETAILS.
17592: #
17593: # (XR) PTR TO FIRST LOCATION TO PROCESS
17594: # (XL) PTR PAST LAST LOCATION TO PROCESS
17595: # JSR GBCPF CALL TO PROCESS FIELDS
17596: # (XR,WA,WB,WC,IA) DESTROYED
17597: #
17598: # NOTE THAT ALTHOUGH THIS PROCEDURE USES A RECURSIVE
17599: # APPROACH, IT CONTROLS ITS OWN STACK AND IS NOT RECURSIVE.
17600: #
17601: gbcpf: #prc # entry point
17602: clrl -(sp) # set zero to mark bottom of stack
17603: movl r10,-(sp) # save end pointer
17604: #
17605: # MERGE HERE TO GO DOWN A LEVEL AND START A NEW LOOP
17606: #
17607: # 1(XS) NEXT LVL FIELD PTR (0 AT OUTER LVL)
17608: # 0(XS) PTR PAST LAST FIELD TO PROCESS
17609: # (XR) PTR TO FIRST FIELD TO PROCESS
17610: #
17611: # LOOP TO PROCESS SUCCESSIVE FIELDS
17612: #
17613: gpf01: movl (r9),r10 # load field contents
17614: movl r9,r8 # save field pointer
17615: cmpl r10,dnamb # jump if not ptr into dynamic area
17616: blssu gpf02
17617: cmpl r10,dnamp # jump if not ptr into dynamic area
17618: bgequ gpf02
17619: #
17620: # HERE WE HAVE A PTR TO A BLOCK IN THE DYNAMIC AREA.
17621: # LINK THIS FIELD ONTO THE REFERENCE BACKCHAIN.
17622: #
17623: movl (r10),r6 # load ptr to chain (or entry ptr)
17624: movl r9,(r10) # set this field as new head of chain
17625: movl r6,(r9) # set forward pointer
17626: #
17627: # NOW SEE IF THIS BLOCK HAS BEEN PROCESSED BEFORE
17628: #
17629: cmpl r6,$p$yyy # jump if already processed
17630: bgequ gpf02
17631: cmpl r6,$b$aaa # jump if not already processed
17632: bgequ gpf03
17633: #
17634: # HERE TO MOVE TO NEXT FIELD
17635: #
17636: gpf02: movl r8,r9 # restore field pointer
17637: addl2 $4,r9 # bump to next field
17638: cmpl r9,(sp) # loop back if more to go
17639: bnequ gpf01
17640: #page
17641: #
17642: # GBCPF (CONTINUED)
17643: #
17644: # HERE WE POP UP A LEVEL AFTER FINISHING A BLOCK
17645: #
17646: movl (sp)+,r10 # restore pointer past end
17647: movl (sp)+,r8 # restore block pointer
17648: tstl r8 # continue loop unless outer levl
17649: bnequ gpf02
17650: rsb # return to caller if outer level
17651: #
17652: # HERE TO PROCESS AN ACTIVE BLOCK WHICH HAS NOT BEEN DONE
17653: #
17654: gpf03: movl r10,r9 # copy block pointer
17655: movl r6,r10 # copy first word of block
17656: movzwl -2(r10),r10 # load entry point id (bl$xx)
17657: #
17658: # BLOCK TYPE SWITCH. NOTE THAT BLOCKS WITH NO RELOCATABLE
17659: # FIELDS JUST RETURN TO GPF02 HERE TO CONTINE TO NEXT FLD.
17660: #
17661: casel r10,$0,$bl$$$ # switch on block type
17662: 5:
17663: .word gpf06-5b # arblk
17664: .word gpf18-5b # bcblk
17665: .word gpf08-5b # cdblk
17666: .word gpf17-5b # exblk
17667: .word gpf02-5b # icblk
17668: .word gpf10-5b # nmblk
17669: .word gpf10-5b # p0blk
17670: .word gpf12-5b # p1blk
17671: .word gpf12-5b # p2blk
17672: .word gpf02-5b # rcblk
17673: .word gpf02-5b # scblk
17674: .word gpf02-5b # seblk
17675: .word gpf08-5b # tbblk
17676: .word gpf08-5b # vcblk
17677: .word gpf02-5b # xnblk
17678: .word gpf09-5b # xrblk
17679: .word gpf13-5b # pdblk
17680: .word gpf16-5b # trblk
17681: .word gpf02-5b # bfblk
17682: .word gpf07-5b # ccblk
17683: .word gpf04-5b # cmblk
17684: .word gpf02-5b # ctblk
17685: .word gpf02-5b # dfblk
17686: .word gpf02-5b # efblk
17687: .word gpf10-5b # evblk
17688: .word gpf11-5b # ffblk
17689: .word gpf02-5b # kvblk
17690: .word gpf14-5b # pfblk
17691: .word gpf15-5b # teblk
17692: #esw # end of jump table
17693: #page
17694: #
17695: # GBCPF (CONTINUED)
17696: #
17697: # CMBLK
17698: #
17699: gpf04: movl 4*cmlen(r9),r6 # load length
17700: movl $4*cmtyp,r7 # set offset
17701: #
17702: # HERE TO PUSH DOWN TO NEW LEVEL
17703: #
17704: # (WC) FIELD PTR AT PREVIOUS LEVEL
17705: # (XR) PTR TO NEW BLOCK
17706: # (WA) LENGTH (RELOC FLDS + FLDS AT START)
17707: # (WB) OFFSET TO FIRST RELOC FIELD
17708: #
17709: gpf05: addl2 r9,r6 # point past last reloc field
17710: addl2 r7,r9 # point to first reloc field
17711: movl r8,-(sp) # stack old field pointer
17712: movl r6,-(sp) # stack new limit pointer
17713: jsb sbchk # check for stack overflow
17714: jmp gpf01 # if ok, back to process
17715: #
17716: # ARBLK
17717: #
17718: gpf06: movl 4*arlen(r9),r6 # load length
17719: movl 4*arofs(r9),r7 # set offset to 1st reloc fld (arpro)
17720: jmp gpf05 # all set
17721: #
17722: # CCBLK
17723: #
17724: gpf07: movl 4*ccuse(r9),r6 # set length in use
17725: movl $4*ccuse,r7 # 1st word (make sure at least one)
17726: jmp gpf05 # all set
17727: #page
17728: #
17729: # GBCPF (CONTINUED)
17730: #
17731: # CDBLK, TBBLK, VCBLK
17732: #
17733: gpf08: movl 4*offs2(r9),r6 # load length
17734: movl $4*offs3,r7 # set offset
17735: jmp gpf05 # jump back
17736: #
17737: # XRBLK
17738: #
17739: gpf09: movl 4*xrlen(r9),r6 # load length
17740: movl $4*xrptr,r7 # set offset
17741: jmp gpf05 # jump back
17742: #
17743: # EVBLK, NMBLK, P0BLK
17744: #
17745: gpf10: movl $4*offs2,r6 # point past second field
17746: movl $4*offs1,r7 # offset is one (only reloc fld is 2)
17747: jmp gpf05 # all set
17748: #
17749: # FFBLK
17750: #
17751: gpf11: movl $4*ffofs,r6 # set length
17752: movl $4*ffnxt,r7 # set offset
17753: jmp gpf05 # all set
17754: #
17755: # P1BLK, P2BLK
17756: #
17757: gpf12: movl $4*parm2,r6 # length (parm2 is non-relocatable)
17758: movl $4*pthen,r7 # set offset
17759: jmp gpf05 # all set
17760: #page
17761: #
17762: # GBCPF (CONTINUED)
17763: #
17764: # PDBLK
17765: #
17766: gpf13: movl 4*pddfp(r9),r10 # load ptr to dfblk
17767: movl 4*dfpdl(r10),r6 # get pdblk length
17768: movl $4*pdfld,r7 # set offset
17769: jmp gpf05 # all set
17770: #
17771: # PFBLK
17772: #
17773: gpf14: movl $4*pfarg,r6 # length past last reloc
17774: movl $4*pfcod,r7 # offset to first reloc
17775: jmp gpf05 # all set
17776: #
17777: # TEBLK
17778: #
17779: gpf15: movl $4*tesi$,r6 # set length
17780: movl $4*tesub,r7 # and offset
17781: jmp gpf05 # all set
17782: #
17783: # TRBLK
17784: #
17785: gpf16: movl $4*trsi$,r6 # set length
17786: movl $4*trval,r7 # and offset
17787: jmp gpf05 # all set
17788: #
17789: # EXBLK
17790: #
17791: gpf17: movl 4*exlen(r9),r6 # load length
17792: movl $4*exflc,r7 # set offset
17793: jmp gpf05 # jump back
17794: #
17795: # BCBLK
17796: #
17797: gpf18: movl $4*bcsi$,r6 # set length
17798: movl $4*bcbuf,r7 # and offset
17799: jmp gpf05 # all set
17800: #enp # end procedure gbcpf
17801: #page
17802: #
17803: # GTARR -- GET ARRAY
17804: #
17805: # GTARR IS PASSED AN OBJECT AND RETURNS AN ARRAY IF POSSIBL
17806: #
17807: # (XR) VALUE TO BE CONVERTED
17808: # JSR GTARR CALL TO GET ARRAY
17809: # PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
17810: # (XR) RESULTING ARRAY
17811: # (XL,WA,WB,WC) DESTROYED
17812: #
17813: gtarr: #prc # entry point
17814: movl (r9),r6 # load type word
17815: cmpl r6,$b$art # exit if already an array
17816: bnequ 0f
17817: jmp gtar8
17818: 0:
17819: cmpl r6,$b$vct # exit if already an array
17820: bnequ 0f
17821: jmp gtar8
17822: 0:
17823: cmpl r6,$b$tbt # else fail if not a table (sgd02)
17824: beqlu 0f
17825: jmp gta9a
17826: 0:
17827: #
17828: # HERE WE CONVERT A TABLE TO AN ARRAY
17829: #
17830: movl r9,-(sp) # replace tbblk pointer on stack
17831: clrl r9 # signal first pass
17832: clrl r7 # zero non-null element count
17833: #
17834: # THE FOLLOWING CODE IS EXECUTED TWICE. ON THE FIRST PASS,
17835: # SIGNALLED BY XR=0, THE NUMBER OF NON-NULL ELEMENTS IN
17836: # THE TABLE IS COUNTED IN WB. IN THE SECOND PASS, WHERE
17837: # XR IS A POINTER INTO THE ARBLK, THE NAME AND VALUE ARE
17838: # ENTERED INTO THE CURRENT ARBLK LOCATION.
17839: #
17840: gtar1: movl (sp),r10 # point to table
17841: addl2 4*tblen(r10),r10# point past last bucket
17842: subl2 $4*tbbuk,r10 # set first bucket offset
17843: movl r10,r6 # copy adjusted pointer
17844: #
17845: # LOOP THROUGH BUCKETS IN TABLE BLOCK
17846: # NEXT THREE LINES OF CODE RELY ON TENXT HAVING A VALUE
17847: # 1 LESS THAN TBBUK.
17848: #
17849: gtar2: movl r6,r10 # copy bucket pointer
17850: subl2 $4,r6 # decrement bucket pointer
17851: #
17852: # LOOP THROUGH TEBLKS ON ONE BUCKET CHAIN
17853: #
17854: gtar3: movl 4*tenxt(r10),r10# point to next teblk
17855: cmpl r10,(sp) # jump if chain end (tbblk ptr)
17856: beqlu gtar6
17857: movl r10,cnvtp # else save teblk pointer
17858: #
17859: # LOOP TO FIND VALUE DOWN TRBLK CHAIN
17860: #
17861: gtar4: movl 4*teval(r10),r10# load value
17862: cmpl (r10),$b$trt # loop till value found
17863: beqlu gtar4
17864: movl r10,r8 # copy value
17865: movl cnvtp,r10 # restore teblk pointer
17866: #page
17867: #
17868: # GTARR (CONTINUED)
17869: #
17870: # NOW CHECK FOR NULL AND TEST CASES
17871: #
17872: cmpl r8,$nulls # loop back to ignore null value
17873: beqlu gtar3
17874: tstl r9 # jump if second pass
17875: bnequ gtar5
17876: incl r7 # for the first pass, bump count
17877: jmp gtar3 # and loop back for next teblk
17878: #
17879: # HERE IN SECOND PASS
17880: #
17881: gtar5: movl 4*tesub(r10),(r9)+ # store subscript name
17882: movl r8,(r9)+ # store value in arblk
17883: jmp gtar3 # loop back for next teblk
17884: #
17885: # HERE AFTER SCANNING TEBLKS ON ONE CHAIN
17886: #
17887: gtar6: cmpl r6,(sp) # loop back if more buckets to go
17888: bnequ gtar2
17889: tstl r9 # else jump if second pass
17890: bnequ gtar7
17891: #
17892: # HERE AFTER COUNTING NON-NULL ELEMENTS
17893: #
17894: tstl r7 # fail if no non-null elements
17895: bnequ 0f
17896: jmp gtar9
17897: 0:
17898: movl r7,r6 # else copy count
17899: addl2 r7,r6 # double (two words/element)
17900: addl2 $arvl2,r6 # add space for standard fields
17901: moval 0[r6],r6 # convert length to bytes
17902: cmpl r6,mxlen # fail if too long for array
17903: blssu 0f
17904: jmp gtar9
17905: 0:
17906: jsb alloc # else allocate space for arblk
17907: movl $b$art,(r9) # store type word
17908: clrl 4*idval(r9) # zero id for the moment
17909: movl r6,4*arlen(r9) # store length
17910: movl $num02,4*arndm(r9) # set dimensions = 2
17911: movl intv1,r5 # get integer one
17912: movl r5,4*arlbd(r9) # store as lbd 1
17913: movl r5,4*arlb2(r9) # store as lbd 2
17914: movl intv2,r5 # load integer two
17915: movl r5,4*ardm2(r9) # store as dim 2
17916: movl r7,r5 # get element count as integer
17917: movl r5,4*ardim(r9) # store as dim 1
17918: clrl 4*arpr2(r9) # zero prototype field for now
17919: movl $4*arpr2,4*arofs(r9) # set offset field (signal pass 2)
17920: movl r9,r7 # save arblk pointer
17921: addl2 $4*arvl2,r9 # point to first element location
17922: jmp gtar1 # jump back to fill in elements
17923: #page
17924: #
17925: # GTARR (CONTINUED)
17926: #
17927: # HERE AFTER FILLING IN ELEMENT VALUES
17928: #
17929: gtar7: movl r7,r9 # restore arblk pointer
17930: movl r7,(sp) # store as result
17931: #
17932: # NOW WE NEED THE ARRAY PROTOTYPE WHICH IS OF THE FORM NN,2
17933: # THIS IS OBTAINED BY BUILDING THE STRING FOR NN02 AND
17934: # CHANGING THE ZERO TO A COMMA BEFORE STORING IT.
17935: #
17936: movl 4*ardim(r9),r5 # get number of elements (nn)
17937: mull2 intvh,r5 # multiply by 100
17938: addl2 intv2,r5 # add 2 (nn02)
17939: jsb icbld # build integer
17940: movl r9,-(sp) # store ptr for gtstg
17941: jsb gtstg # convert to string
17942: .long invalid$ # convert fail is impossible
17943: movl r9,r10 # copy string pointer
17944: movl (sp)+,r9 # reload arblk pointer
17945: movl r10,4*arpr2(r9) # store prototype ptr (nn02)
17946: subl2 $num02,r6 # adjust length to point to zero
17947: movab cfp$f(r10)[r6],r10 # point to zero
17948: movl $ch$cm,r7 # load a comma
17949: movb r7,(r10) # store a comma over the zero
17950: #csc r10 # complete store characters
17951: #
17952: # NORMAL RETURN
17953: #
17954: gtar8: addl2 $4*1,(sp) # return to caller
17955: rsb
17956: #
17957: # NON-CONVERSION RETURN
17958: #
17959: gtar9: movl (sp)+,r9 # restore stack for conv err (sgd02)
17960: #
17961: # MERGE TO TAKE CONVERT ERROR WHEN STACK ADJUSTED OK
17962: #
17963: gta9a: movl (sp)+,r11 # return
17964: jmp *(r11)+
17965: #enp # procedure gtarr
17966: #page
17967: #
17968: # GTCOD -- CONVERT TO CODE
17969: #
17970: # (XR) OBJECT TO BE CONVERTED
17971: # JSR GTCOD CALL TO CONVERT TO CODE
17972: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17973: # (XR) POINTER TO RESULTING CDBLK
17974: # (XL,WA,WB,WC,RA) DESTROYED
17975: #
17976: # IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE-
17977: # EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
17978: # WITHOUT RETURNING TO THIS ROUTINE.
17979: #
17980: gtcod: #prc # entry point
17981: cmpl (r9),$b$cds # jump if already code
17982: beqlu gtcd1
17983: cmpl (r9),$b$cdc # jump if already code
17984: beqlu gtcd1
17985: #
17986: # HERE WE MUST GENERATE A CDBLK BY COMPILATION
17987: #
17988: movl r9,-(sp) # stack argument for gtstg
17989: jsb gtstg # convert argument to string
17990: .long gtcd2 # jump if non-convertible
17991: movl flptr,gtcef # save fail ptr in case of error
17992: movl r$cod,r$gtc # also save code ptr
17993: movl r9,r$cim # else set image pointer
17994: movl r6,scnil # set image length
17995: clrl scnpt # set scan pointer
17996: movl $stgxc,stage # set stage for execute compile
17997: movl cmpsn,lstsn # in case listr called
17998: jsb cmpil # compile string
17999: movl $stgxt,stage # reset stage for execute time
18000: clrl r$cim # clear image
18001: #
18002: # MERGE HERE IF NO CONVERT REQUIRED
18003: #
18004: gtcd1: addl2 $4*1,(sp) # give normal gtcod return
18005: rsb
18006: #
18007: # HERE IF UNCONVERTIBLE
18008: #
18009: gtcd2: movl (sp)+,r11 # give error return
18010: jmp *(r11)+
18011: #enp # end procedure gtcod
18012: #page
18013: #
18014: # GTEXP -- CONVERT TO EXPRESSION
18015: #
18016: # (XR) INPUT VALUE TO BE CONVERTED
18017: # JSR GTEXP CALL TO CONVERT TO EXPRESSION
18018: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
18019: # (XR) POINTER TO RESULT EXBLK OR SEBLK
18020: # (XL,WA,WB,WC,RA) DESTROYED
18021: #
18022: # IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE-
18023: # EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
18024: # WITHOUT RETURNING TO THIS ROUTINE.
18025: #
18026: gtexp: #prc # entry point
18027: cmpl (r9),$b$e$$ # jump if already an expression
18028: bgtru 0f
18029: jmp gtex1
18030: 0:
18031: movl r9,-(sp) # store argument for gtstg
18032: jsb gtstg # convert argument to string
18033: .long gtex2 # jump if unconvertible
18034: #
18035: # CHECK THE LAST CHARACTER OF THE STRING FOR COLON OR
18036: # SEMICOLON. THESE CHARACTERS CAN LEGITIMATELY END AN
18037: # EXPRESSION IN OPEN CODE, SO EXPAN WILL NOT DETECT THEM
18038: # AS ERRORS, BUT THEY ARE INVALID AS TERMINATORS FOR A
18039: # STRING THAT IS BEING CONVERTED TO EXPRESSION FORM.
18040: #
18041: movl r9,r10 # copy input string pointer (reg06)
18042: movab cfp$f(r10)[r6],r10 # point one past the string end (reg06)
18043: movzbl -(r10),r10 # fetch the last character (reg06)
18044: cmpl r10,$ch$cl # error if it is a semicolon (reg06)
18045: beqlu gtex2
18046: cmpl r10,$ch$sm # or if it is a colon (reg06)
18047: beqlu gtex2
18048: #
18049: # HERE WE CONVERT A STRING BY COMPILATION
18050: #
18051: movl r9,r$cim # set input image pointer
18052: clrl scnpt # set scan pointer
18053: movl r6,scnil # set input image length
18054: clrl r7 # set code for normal scan
18055: movl flptr,gtcef # save fail ptr in case of error
18056: movl r$cod,r$gtc # also save code ptr
18057: movl $stgev,stage # adjust stage for compile
18058: movl $t$uok,scntp # indicate unary operator acceptable
18059: jsb expan # build tree for expression
18060: clrl scnrs # reset rescan flag
18061: cmpl scnpt,scnil # error if not end of image
18062: bnequ gtex2
18063: clrl r7 # set ok value for cdgex call
18064: movl r9,r10 # copy tree pointer
18065: jsb cdgex # build expression block
18066: clrl r$cim # clear pointer
18067: movl $stgxt,stage # restore stage for execute time
18068: #
18069: # MERGE HERE IF NO CONVERSION REQUIRED
18070: #
18071: gtex1: addl2 $4*1,(sp) # return to gtexp caller
18072: rsb
18073: #
18074: # HERE IF UNCONVERTIBLE
18075: #
18076: gtex2: movl (sp)+,r11 # take error exit
18077: jmp *(r11)+
18078: #enp # end procedure gtexp
18079: #page
18080: #
18081: # GTINT -- GET INTEGER VALUE
18082: #
18083: # GTINT IS PASSED AN OBJECT AND RETURNS AN INTEGER AFTER
18084: # PERFORMING ANY NECESSARY CONVERSIONS.
18085: #
18086: # (XR) VALUE TO BE CONVERTED
18087: # JSR GTINT CALL TO CONVERT TO INTEGER
18088: # PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
18089: # (XR) RESULTING INTEGER
18090: # (WC,RA) DESTROYED
18091: # (WA,WB) DESTROYED (ONLY ON CONVERSION ERR)
18092: # (XR) UNCHANGED (ON CONVERT ERROR)
18093: #
18094: gtint: #prc # entry point
18095: cmpl (r9),$b$icl # jump if already an integer
18096: beqlu gtin2
18097: movl r6,gtina # else save wa
18098: movl r7,gtinb # save wb
18099: jsb gtnum # convert to numeric
18100: .long gtin3 # jump if unconvertible
18101: cmpl r6,$b$icl # jump if integer
18102: beqlu gtin1
18103: #
18104: # HERE WE CONVERT A REAL TO INTEGER
18105: #
18106: movf 4*rcval(r9),r2 # load real value
18107: cvtfl r2,r5 # convert to integer (err if ovflow)
18108: bvs gtin3
18109: jsb icbld # if ok build icblk
18110: #
18111: # HERE AFTER SUCCESSFUL CONVERSION TO INTEGER
18112: #
18113: gtin1: movl gtina,r6 # restore wa
18114: movl gtinb,r7 # restore wb
18115: #
18116: # COMMON EXIT POINT
18117: #
18118: gtin2: addl2 $4*1,(sp) # return to gtint caller
18119: rsb
18120: #
18121: # HERE ON CONVERSION ERROR
18122: #
18123: gtin3: movl (sp)+,r11 # take convert error exit
18124: jmp *(r11)+
18125: #enp # end procedure gtint
18126: #page
18127: #
18128: # GTNUM -- GET NUMERIC VALUE
18129: #
18130: # GTNUM IS GIVEN AN OBJECT AND RETURNS EITHER AN INTEGER
18131: # OR A REAL, PERFORMING ANY NECESSARY CONVERSIONS.
18132: #
18133: # (XR) OBJECT TO BE CONVERTED
18134: # JSR GTNUM CALL TO CONVERT TO NUMERIC
18135: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
18136: # (XR) POINTER TO RESULT (INT OR REAL)
18137: # (WA) FIRST WORD OF RESULT BLOCK
18138: # (WB,WC,RA) DESTROYED
18139: # (XR) UNCHANGED (ON CONVERT ERROR)
18140: #
18141: gtnum: #prc # entry point
18142: movl (r9),r6 # load first word of block
18143: cmpl r6,$b$icl # jump if integer (no conversion)
18144: bnequ 0f
18145: jmp gtn34
18146: 0:
18147: cmpl r6,$b$rcl # jump if real (no conversion)
18148: bnequ 0f
18149: jmp gtn34
18150: 0:
18151: #
18152: # AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING
18153: # TO AN INTEGER OR REAL AS APPROPRIATE.
18154: #
18155: movl r9,-(sp) # stack argument in case convert err
18156: movl r9,-(sp) # stack argument for gtstg
18157: jsb gtstg # convert argument to string
18158: .long gtn36 # jump if unconvertible
18159: #
18160: # INITIALIZE NUMERIC CONVERSION
18161: #
18162: movl intv0,r5 # initialize integer result to zero
18163: tstl r6 # jump to exit with zero if null
18164: bnequ 0f
18165: jmp gtn32
18166: 0:
18167: # set bct counter for following loops
18168: clrl gtnnf # tentatively indicate result +
18169: movl r5,gtnex # initialise exponent to zero
18170: clrl gtnsc # zero scale in case real
18171: clrl gtndf # reset flag for dec point found
18172: clrl gtnrd # reset flag for digits found
18173: movf reav0,r2 # zero real accum in case real
18174: movab cfp$f(r9),r9 # point to argument characters
18175: #
18176: # MERGE BACK HERE AFTER IGNORING LEADING BLANK
18177: #
18178: gtn01: movzbl (r9)+,r7 # load first character
18179: cmpl r7,$ch$d0 # jump if not digit
18180: blssu gtn02
18181: cmpl r7,$ch$d9 # jump if first char is a digit
18182: blequ gtn06
18183: #page
18184: #
18185: # GTNUM (CONTINUED)
18186: #
18187: # HERE IF FIRST DIGIT IS NON-DIGIT
18188: #
18189: gtn02: cmpl r7,$ch$bl # jump if non-blank
18190: bnequ gtn03
18191: gtna2: sobgtr r6,gtn01 # else decr count and loop back
18192: jmp gtn07 # jump to return zero if all blanks
18193: #
18194: # HERE FOR FIRST CHARACTER NON-BLANK, NON-DIGIT
18195: #
18196: gtn03: cmpl r7,$ch$pl # jump if plus sign
18197: beqlu gtn04
18198: cmpl r7,$ch$ht # horizontal tab equiv to blank
18199: beqlu gtna2
18200: cmpl r7,$ch$mn # jump if not minus (may be real)
18201: beqlu 0f
18202: jmp gtn12
18203: 0:
18204: movl sp,gtnnf # if minus sign, set negative flag
18205: #
18206: # MERGE HERE AFTER PROCESSING SIGN
18207: #
18208: gtn04: sobgtr r6,gtn05 # jump if chars left
18209: jmp gtn36 # else error
18210: #
18211: # LOOP TO FETCH CHARACTERS OF AN INTEGER
18212: #
18213: gtn05: movzbl (r9)+,r7 # load next character
18214: cmpl r7,$ch$d0 # jump if not a digit
18215: blssu gtn08
18216: cmpl r7,$ch$d9 # jump if not a digit
18217: bgtru gtn08
18218: #
18219: # MERGE HERE FOR FIRST DIGIT
18220: #
18221: gtn06: movl r5,gtnsi # save current value
18222: mull2 $10,r5 # current*10-(new dig) jump if ovflow
18223: bvc 0f
18224: jmp gtn35
18225: 0: bicl2 $0xfffffff0,r7
18226: subl2 r7,r5
18227: bvc 1f
18228: jmp gtn35
18229: 1:
18230: movl sp,gtnrd # set digit read flag
18231: sobgtr r6,gtn05 # else loop back if more chars
18232: #
18233: # HERE TO EXIT WITH CONVERTED INTEGER VALUE
18234: #
18235: gtn07: tstl gtnnf # jump if negative (all set)
18236: beqlu 0f
18237: jmp gtn32
18238: 0:
18239: mnegl r5,r5 # else negate
18240: bvs 0f
18241: jmp gtn32
18242: 0:
18243: jmp gtn36 # else signal error
18244: #page
18245: #
18246: # GTNUM (CONTINUED)
18247: #
18248: # HERE FOR A NON-DIGIT CHARACTER WHILE ATTEMPTING TO
18249: # CONVERT AN INTEGER, CHECK FOR TRAILING BLANKS OR REAL.
18250: #
18251: gtn08: cmpl r7,$ch$bl # jump if a blank
18252: beqlu gtna9
18253: cmpl r7,$ch$ht # jump if horizontal tab
18254: beqlu gtna9
18255: cvtlf r5,r2 # else convert integer to real
18256: mnegf r2,r2 # negate to get positive value
18257: jmp gtn12 # jump to try for real
18258: #
18259: # HERE WE SCAN OUT BLANKS TO END OF STRING
18260: #
18261: gtn09: movzbl (r9)+,r7 # get next char
18262: cmpl r7,$ch$ht # jump if horizontal tab
18263: beqlu gtna9
18264: cmpl r7,$ch$bl # error if non-blank
18265: beqlu 0f
18266: jmp gtn36
18267: 0:
18268: gtna9: sobgtr r6,gtn09 # loop back if more chars to check
18269: jmp gtn07 # return integer if all blanks
18270: #
18271: # LOOP TO COLLECT MANTISSA OF REAL
18272: #
18273: gtn10: movzbl (r9)+,r7 # load next character
18274: cmpl r7,$ch$d0 # jump if non-numeric
18275: bgequ 0f
18276: jmp gtn12
18277: 0:
18278: cmpl r7,$ch$d9 # jump if non-numeric
18279: blequ 0f
18280: jmp gtn12
18281: 0:
18282: #
18283: # MERGE HERE TO COLLECT FIRST REAL DIGIT
18284: #
18285: gtn11: subl2 $ch$d0,r7 # convert digit to number
18286: mulf2 reavt,r2 # multiply real by 10.0
18287: bvc 0f
18288: jmp gtn36
18289: 0:
18290: movf r2,gtnsr # save result
18291: movl r7,r5 # get new digit as integer
18292: cvtlf r5,r2 # convert new digit to real
18293: addf2 gtnsr,r2 # add to get new total
18294: addl2 gtndf,gtnsc # increment scale if after dec point
18295: movl sp,gtnrd # set digit found flag
18296: sobgtr r6,gtn10 # loop back if more chars
18297: jmp gtn22 # else jump to scale
18298: #page
18299: #
18300: # GTNUM (CONTINUED)
18301: #
18302: # HERE IF NON-DIGIT FOUND WHILE COLLECTING A REAL
18303: #
18304: gtn12: cmpl r7,$ch$dt # jump if not dec point
18305: bnequ gtn13
18306: tstl gtndf # if dec point, error if one already
18307: beqlu 0f
18308: jmp gtn36
18309: 0:
18310: movl $num01,gtndf # else set flag for dec point
18311: sobgtr r6,gtn10 # loop back if more chars
18312: jmp gtn22 # else jump to scale
18313: #
18314: # HERE IF NOT DECIMAL POINT
18315: #
18316: gtn13: cmpl r7,$ch$le # jump if e for exponent
18317: beqlu gtn15
18318: cmpl r7,$ch$ld # jump if d for exponent
18319: beqlu gtn15
18320: cmpl r7,$ch$$e # jump if e for exponent
18321: beqlu gtn15
18322: cmpl r7,$ch$$d # jump if d for exponent
18323: beqlu gtn15
18324: #
18325: # HERE CHECK FOR TRAILING BLANKS
18326: #
18327: gtn14: cmpl r7,$ch$bl # jump if blank
18328: beqlu gtnb4
18329: cmpl r7,$ch$ht # jump if horizontal tab
18330: beqlu gtnb4
18331: jmp gtn36 # error if non-blank
18332: #
18333: gtnb4: movzbl (r9)+,r7 # get next character
18334: sobgtr r6,gtn14 # loop back to check if more
18335: jmp gtn22 # else jump to scale
18336: #
18337: # HERE TO READ AND PROCESS AN EXPONENT
18338: #
18339: gtn15: clrl gtnes # set exponent sign positive
18340: movl intv0,r5 # initialize exponent to zero
18341: movl sp,gtndf # reset no dec point indication
18342: sobgtr r6,gtn16 # jump skipping past e or d
18343: jmp gtn36 # error if null exponent
18344: #
18345: # CHECK FOR EXPONENT SIGN
18346: #
18347: gtn16: movzbl (r9)+,r7 # load first exponent character
18348: cmpl r7,$ch$pl # jump if plus sign
18349: beqlu gtn17
18350: cmpl r7,$ch$mn # else jump if not minus sign
18351: bnequ gtn19
18352: movl sp,gtnes # set sign negative if minus sign
18353: #
18354: # MERGE HERE AFTER PROCESSING EXPONENT SIGN
18355: #
18356: gtn17: sobgtr r6,gtn18 # jump if chars left
18357: jmp gtn36 # else error
18358: #
18359: # LOOP TO CONVERT EXPONENT DIGITS
18360: #
18361: gtn18: movzbl (r9)+,r7 # load next character
18362: #page
18363: #
18364: # GTNUM (CONTINUED)
18365: #
18366: # MERGE HERE FOR FIRST EXPONENT DIGIT
18367: #
18368: gtn19: cmpl r7,$ch$d0 # jump if not digit
18369: blssu gtn20
18370: cmpl r7,$ch$d9 # jump if not digit
18371: bgtru gtn20
18372: mull2 $10,r5 # else current*10, subtract new digit
18373: bvc 0f
18374: jmp gtn36
18375: 0: bicl2 $0xfffffff0,r7
18376: subl2 r7,r5
18377: bvc 1f
18378: jmp gtn36
18379: 1:
18380: sobgtr r6,gtn18 # loop back if more chars
18381: jmp gtn21 # jump if exponent field is exhausted
18382: #
18383: # HERE TO CHECK FOR TRAILING BLANKS AFTER EXPONENT
18384: #
18385: gtn20: cmpl r7,$ch$bl # jump if blank
18386: beqlu gtnc0
18387: cmpl r7,$ch$ht # jump if horizontal tab
18388: beqlu gtnc0
18389: jmp gtn36 # error if non-blank
18390: #
18391: gtnc0: movzbl (r9)+,r7 # get next character
18392: sobgtr r6,gtn20 # loop back till all blanks scanned
18393: #
18394: # MERGE HERE AFTER COLLECTING EXPONENT
18395: #
18396: gtn21: movl r5,gtnex # save collected exponent
18397: tstl gtnes # jump if it was negative
18398: bnequ gtn22
18399: mnegl r5,r5 # else complement
18400: bvc 0f
18401: jmp gtn36
18402: 0:
18403: movl r5,gtnex # and store positive exponent
18404: #
18405: # MERGE HERE WITH EXPONENT (0 IF NONE GIVEN)
18406: #
18407: gtn22: tstl gtnrd # error if not digits collected
18408: bnequ 0f
18409: jmp gtn36
18410: 0:
18411: tstl gtndf # error if no exponent or dec point
18412: bnequ 0f
18413: jmp gtn36
18414: 0:
18415: movl gtnsc,r5 # else load scale as integer
18416: subl2 gtnex,r5 # subtract exponent
18417: bvc 0f
18418: jmp gtn36
18419: 0:
18420: tstl r5 # jump if we must scale up
18421: blss gtn26
18422: #
18423: # HERE WE HAVE A NEGATIVE EXPONENT, SO SCALE DOWN
18424: #
18425: movl r5,r6 # load scale factor, err if ovflow
18426: bgeq 0f
18427: jmp gtn36
18428: 0:
18429: #
18430: # LOOP TO SCALE DOWN IN STEPS OF 10**10
18431: #
18432: gtn23: cmpl r6,$num10 # jump if 10 or less to go
18433: blequ gtn24
18434: divf2 reatt,r2 # else divide by 10**10
18435: subl2 $num10,r6 # decrement scale
18436: jmp gtn23 # and loop back
18437: #page
18438: #
18439: # GTNUM (CONTINUED)
18440: #
18441: # HERE SCALE REST OF WAY FROM POWERS OF TEN TABLE
18442: #
18443: gtn24: tstl r6 # jump if scaled
18444: beqlu gtn30
18445: movl $cfp$r,r7 # else get indexing factor
18446: movl $reav1,r9 # point to powers of ten table
18447: moval 0[r6],r6 # convert remaining scale to byte ofs
18448: #
18449: # LOOP TO POINT TO POWERS OF TEN TABLE ENTRY
18450: #
18451: gtn25: addl2 r6,r9 # bump pointer
18452: sobgtr r7,gtn25 # once for each value word
18453: divf2 (r9),r2 # scale down as required
18454: jmp gtn30 # and jump
18455: #
18456: # COME HERE TO SCALE RESULT UP (POSITIVE EXPONENT)
18457: #
18458: gtn26: mnegl r5,r5 # get absolute value of exponent
18459: bvc 0f
18460: jmp gtn36
18461: 0:
18462: movl r5,r6 # acquire scale, error if ovflow
18463: bgeq 0f
18464: jmp gtn36
18465: 0:
18466: #
18467: # LOOP TO SCALE UP IN STEPS OF 10**10
18468: #
18469: gtn27: cmpl r6,$num10 # jump if 10 or less to go
18470: blequ gtn28
18471: mulf2 reatt,r2 # else multiply by 10**10
18472: bvc 0f
18473: jmp gtn36
18474: 0:
18475: subl2 $num10,r6 # else decrement scale
18476: jmp gtn27 # and loop back
18477: #
18478: # HERE TO SCALE UP REST OF WAY WITH TABLE
18479: #
18480: gtn28: tstl r6 # jump if scaled
18481: beqlu gtn30
18482: movl $cfp$r,r7 # else get indexing factor
18483: movl $reav1,r9 # point to powers of ten table
18484: moval 0[r6],r6 # convert remaining scale to byte ofs
18485: #
18486: # LOOP TO POINT TO PROPER ENTRY IN POWERS OF TEN TABLE
18487: #
18488: gtn29: addl2 r6,r9 # bump pointer
18489: sobgtr r7,gtn29 # once for each word in value
18490: mulf2 (r9),r2 # scale up
18491: bvc 0f
18492: jmp gtn36
18493: 0:
18494: #page
18495: #
18496: # GTNUM (CONTINUED)
18497: #
18498: # HERE WITH REAL VALUE SCALED AND READY EXCEPT FOR SIGN
18499: #
18500: gtn30: tstl gtnnf # jump if positive
18501: beqlu gtn31
18502: mnegf r2,r2 # else negate
18503: #
18504: # HERE WITH PROPERLY SIGNED REAL VALUE IN (RA)
18505: #
18506: gtn31: jsb rcbld # build real block
18507: jmp gtn33 # merge to exit
18508: #
18509: # HERE WITH PROPERLY SIGNED INTEGER VALUE IN (IA)
18510: #
18511: gtn32: jsb icbld # build icblk
18512: #
18513: # REAL MERGES HERE
18514: #
18515: gtn33: movl (r9),r6 # load first word of result block
18516: addl2 $4,sp # pop argument off stack
18517: #
18518: # COMMON EXIT POINT
18519: #
18520: gtn34: addl2 $4*1,(sp) # return to gtnum caller
18521: rsb
18522: #
18523: # COME HERE IF OVERFLOW OCCURS DURING COLLECTION OF INTEGER
18524: #
18525: gtn35: movl gtnsi,r5 # reload integer so far
18526: cvtlf r5,r2 # convert to real
18527: mnegf r2,r2 # make value positive
18528: jmp gtn11 # merge with real circuit
18529: #
18530: # HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR
18531: #
18532: gtn36: movl (sp)+,r9 # reload original argument
18533: movl (sp)+,r11 # take convert-error exit
18534: jmp *(r11)+
18535: #enp # end procedure gtnum
18536: #page
18537: #
18538: # GTNVR -- CONVERT TO NATURAL VARIABLE
18539: #
18540: # GTNVR LOCATES A VARIABLE BLOCK (VRBLK) GIVEN EITHER AN
18541: # APPROPRIATE NAME (NMBLK) OR A NON-NULL STRING (SCBLK).
18542: #
18543: # (XR) ARGUMENT
18544: # JSR GTNVR CALL TO CONVERT TO NATURAL VARIABLE
18545: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
18546: # (XR) POINTER TO VRBLK
18547: # (WA,WB) DESTROYED (CONVERSION ERROR ONLY)
18548: # (WC) DESTROYED
18549: #
18550: gtnvr: #prc # entry point
18551: cmpl (r9),$b$nml # jump if not name
18552: bnequ gnv02
18553: movl 4*nmbas(r9),r9 # else load name base if name
18554: cmpl r9,state # skip if vrblk (in static region)
18555: bgtru 0f
18556: jmp gnv07
18557: 0:
18558: #
18559: # COMMON ERROR EXIT
18560: #
18561: gnv01: movl (sp)+,r11 # take convert-error exit
18562: jmp *(r11)+
18563: #
18564: # HERE IF NOT NAME
18565: #
18566: gnv02: movl r6,gnvsa # save wa
18567: movl r7,gnvsb # save wb
18568: movl r9,-(sp) # stack argument for gtstg
18569: jsb gtstg # convert argument to string
18570: .long gnv01 # jump if conversion error
18571: tstl r6 # null string is an error
18572: beqlu gnv01
18573: jsb flstg # fold lower case to upper case
18574: movl r10,-(sp) # save xl
18575: movl r9,-(sp) # stack string ptr for later
18576: movl r9,r7 # copy string pointer
18577: addl2 $4*schar,r7 # point to characters of string
18578: movl r7,gnvst # save pointer to characters
18579: movl r6,r7 # copy length
18580: movab 3+(4*0)(r7),r7 # get number of words in name
18581: ashl $-2,r7,r7
18582: movl r7,gnvnw # save for later
18583: jsb hashs # compute hash index for string
18584: ashq $-32,r4,r4 # compute hash offset by taking mod
18585: ediv hshnb,r4,r11,r5
18586: movl r5,r8 # get as offset
18587: moval 0[r8],r8 # convert offset to bytes
18588: addl2 hshtb,r8 # point to proper hash chain
18589: subl2 $4*vrnxt,r8 # subtract offset to merge into loop
18590: #page
18591: #
18592: # GTNVR (CONTINUED)
18593: #
18594: # LOOP TO SEARCH HASH CHAIN
18595: #
18596: gnv03: movl r8,r10 # copy hash chain pointer
18597: movl 4*vrnxt(r10),r10# point to next vrblk on chain
18598: tstl r10 # jump if end of chain
18599: beqlu gnv08
18600: movl r10,r8 # save pointer to this vrblk
18601: tstl 4*vrlen(r10) # jump if not system variable
18602: bnequ gnv04
18603: movl 4*vrsvp(r10),r10# else point to svblk
18604: subl2 $4*vrsof,r10 # adjust offset for merge
18605: #
18606: # MERGE HERE WITH STRING PTR (LIKE VRBLK) IN XL
18607: #
18608: gnv04: cmpl r6,4*vrlen(r10) # back for next vrblk if lengths ne
18609: bnequ gnv03
18610: addl2 $4*vrchs,r10 # else point to chars of chain entry
18611: movl gnvnw,r7 # get word counter to control loop
18612: movl gnvst,r9 # point to chars of new name
18613: #
18614: # LOOP TO COMPARE CHARACTERS OF THE TWO NAMES
18615: #
18616: gnv05: cmpl (r9),(r10) # jump if no match for next vrblk
18617: bnequ gnv03
18618: addl2 $4,r9 # bump new name pointer
18619: addl2 $4,r10 # bump vrblk in chain name pointer
18620: sobgtr r7,gnv05 # else loop till all compared
18621: movl r8,r9 # we have found a match, get vrblk
18622: #
18623: # EXIT POINT AFTER FINDING VRBLK OR BUILDING NEW ONE
18624: #
18625: gnv06: movl gnvsa,r6 # restore wa
18626: movl gnvsb,r7 # restore wb
18627: addl2 $4,sp # pop string pointer
18628: movl (sp)+,r10 # restore xl
18629: #
18630: # COMMON EXIT POINT
18631: #
18632: gnv07: addl2 $4*1,(sp) # return to gtnvr caller
18633: rsb
18634: #
18635: # NOT FOUND, PREPARE TO SEARCH SYSTEM VARIABLE TABLE
18636: #
18637: gnv08: clrl r9 # clear garbage xr pointer
18638: movl r8,gnvhe # save ptr to end of hash chain
18639: cmpl r6,$num09 # cannot be system var if length gt 9
18640: bgtru gnv14
18641: movl r6,r10 # else copy length
18642: moval 0[r10],r10 # convert to byte offset
18643: movl l^vsrch(r10),r10# point to first svblk of this length
18644: #page
18645: #
18646: # GTNVR (CONTINUED)
18647: #
18648: # LOOP TO SEARCH ENTRIES IN STANDARD VARIABLE TABLE
18649: #
18650: gnv09: movl r10,gnvsp # save table pointer
18651: movl (r10)+,r8 # load svbit bit string
18652: movl (r10)+,r7 # load length from table entry
18653: cmpl r6,r7 # jump if end of right length entires
18654: bnequ gnv14
18655: movl gnvnw,r7 # get word counter to control loop
18656: movl gnvst,r9 # point to chars of new name
18657: #
18658: # LOOP TO CHECK FOR MATCHING NAMES
18659: #
18660: gnv10: cmpl (r9),(r10) # jump if name mismatch
18661: bnequ gnv11
18662: addl2 $4,r9 # else bump new name pointer
18663: addl2 $4,r10 # bump svblk pointer
18664: sobgtr r7,gnv10 # else loop until all checked
18665: #
18666: # HERE WE HAVE A MATCH IN THE STANDARD VARIABLE TABLE
18667: #
18668: clrl r8 # set vrlen value zero
18669: movl $4*vrsi$,r6 # set standard size
18670: jmp gnv15 # jump to build vrblk
18671: #
18672: # HERE IF NO MATCH WITH TABLE ENTRY IN SVBLKS TABLE
18673: #
18674: gnv11: addl2 $4,r10 # bump past word of chars
18675: sobgtr r7,gnv11 # loop back if more to go
18676: ashl $-svnbt,r8,r8 # remove uninteresting bits
18677: #
18678: # LOOP TO BUMP TABLE PTR FOR EACH FLAGGED WORD
18679: #
18680: gnv12: movl bits1,r7 # load bit to test
18681: mcoml r8,r11 # test for word present
18682: bicl2 r11,r7
18683: tstl r7 # jump if not present
18684: beqlu gnv13
18685: addl2 $4,r10 # else bump table pointer
18686: #
18687: # HERE AFTER DEALING WITH ONE WORD (ONE BIT)
18688: #
18689: gnv13: ashl $-1,r8,r8 # remove bit already processed
18690: tstl r8 # loop back if more bits to test
18691: bnequ gnv12
18692: jmp gnv09 # else loop back for next svblk
18693: #
18694: # HERE IF NOT SYSTEM VARIABLE
18695: #
18696: gnv14: movl r6,r8 # copy vrlen value
18697: movl $vrchs,r6 # load standard size -chars
18698: addl2 gnvnw,r6 # adjust for chars of name
18699: moval 0[r6],r6 # convert length to bytes
18700: #page
18701: #
18702: # GTNVR (CONTINUED)
18703: #
18704: # MERGE HERE TO BUILD VRBLK
18705: #
18706: gnv15: jsb alost # allocate space for vrblk (static)
18707: movl r9,r7 # save vrblk pointer
18708: movl $stnvr,r10 # point to model variable block
18709: movl $4*vrlen,r6 # set length of standard fields
18710: jsb sbmvw # set initial fields of new block
18711: movl gnvhe,r10 # load pointer to end of hash chain
18712: movl r7,4*vrnxt(r10) # add new block to end of chain
18713: movl r8,(r9)+ # set vrlen field, bump ptr
18714: movl gnvnw,r6 # get length in words
18715: moval 0[r6],r6 # convert to length in bytes
18716: tstl r8 # jump if system variable
18717: beqlu gnv16
18718: #
18719: # HERE FOR NON-SYSTEM VARIABLE -- SET CHARS OF NAME
18720: #
18721: movl (sp),r10 # point back to string name
18722: addl2 $4*schar,r10 # point to chars of name
18723: jsb sbmvw # move characters into place
18724: movl r7,r9 # restore vrblk pointer
18725: jmp gnv06 # jump back to exit
18726: #
18727: # HERE FOR SYSTEM VARIABLE CASE TO FILL IN FIELDS WHERE
18728: # NECESSARY FROM THE FIELDS PRESENT IN THE SVBLK.
18729: #
18730: gnv16: movl gnvsp,r10 # load pointer to svblk
18731: movl r10,(r9) # set svblk ptr in vrblk
18732: movl r7,r9 # restore vrblk pointer
18733: movl 4*svbit(r10),r7 # load bit indicators
18734: addl2 $4*svchs,r10 # point to characters of name
18735: addl2 r6,r10 # point past characters
18736: #
18737: # SKIP PAST KEYWORD NUMBER (SVKNM) IF PRESENT
18738: #
18739: movl btknm,r8 # load test bit
18740: mcoml r7,r11 # and to test
18741: bicl2 r11,r8
18742: tstl r8 # jump if no keyword number
18743: beqlu gnv17
18744: addl2 $4,r10 # else bump pointer
18745: #page
18746: #
18747: # GTNVR (CONTINUED)
18748: #
18749: # HERE TEST FOR FUNCTION (SVFNC AND SVNAR)
18750: #
18751: gnv17: movl btfnc,r8 # get test bit
18752: mcoml r7,r11 # and to test
18753: bicl2 r11,r8
18754: tstl r8 # skip if no system function
18755: beqlu gnv18
18756: movl r10,4*vrfnc(r9) # else point vrfnc to svfnc field
18757: addl2 $4*num02,r10 # and bump past svfnc, svnar fields
18758: #
18759: # NOW TEST FOR LABEL (SVLBL)
18760: #
18761: gnv18: movl btlbl,r8 # get test bit
18762: mcoml r7,r11 # and to test
18763: bicl2 r11,r8
18764: tstl r8 # jump if bit is off (no system labl)
18765: beqlu gnv19
18766: movl r10,4*vrlbl(r9) # else point vrlbl to svlbl field
18767: addl2 $4,r10 # bump past svlbl field
18768: #
18769: # NOW TEST FOR VALUE (SVVAL)
18770: #
18771: gnv19: movl btval,r8 # load test bit
18772: mcoml r7,r11 # and to test
18773: bicl2 r11,r8
18774: tstl r8 # all done if no value
18775: bnequ 0f
18776: jmp gnv06
18777: 0:
18778: movl (r10),4*vrval(r9)# else set initial value
18779: movl $b$vre,4*vrsto(r9) # set error store access
18780: jmp gnv06 # merge back to exit to caller
18781: #enp # end procedure gtnvr
18782: #page
18783: #
18784: # GTPAT -- GET PATTERN
18785: #
18786: # GTPAT IS PASSED AN OBJECT IN (XR) AND RETURNS A
18787: # PATTERN AFTER PERFORMING ANY NECESSARY CONVERSIONS
18788: #
18789: # (XR) INPUT ARGUMENT
18790: # JSR GTPAT CALL TO CONVERT TO PATTERN
18791: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
18792: # (XR) RESULTING PATTERN
18793: # (WA) DESTROYED
18794: # (WB) DESTROYED (ONLY ON CONVERT ERROR)
18795: # (XR) UNCHANGED (ONLY ON CONVERT ERROR)
18796: #
18797: gtpat: #prc # entry point
18798: cmpl (r9),$p$aaa # jump if pattern already
18799: bgequ gtpt5
18800: #
18801: # HERE IF NOT PATTERN, TRY FOR STRING
18802: #
18803: movl r7,gtpsb # save wb
18804: movl r9,-(sp) # stack argument for gtstg
18805: jsb gtstg # convert argument to string
18806: .long gtpt2 # jump if impossible
18807: #
18808: # HERE WE HAVE A STRING
18809: #
18810: tstl r6 # jump if non-null
18811: bnequ gtpt1
18812: #
18813: # HERE FOR NULL STRING. GENERATE POINTER TO NULL PATTERN.
18814: #
18815: movl $ndnth,r9 # point to nothen node
18816: jmp gtpt4 # jump to exit
18817: #page
18818: #
18819: # GTPAT (CONTINUED)
18820: #
18821: # HERE FOR NON-NULL STRING
18822: #
18823: gtpt1: movl $p$str,r7 # load pcode for multi-char string
18824: cmpl r6,$num01 # jump if multi-char string
18825: bnequ gtpt3
18826: #
18827: # HERE FOR ONE CHARACTER STRING, SHARE ONE CHARACTER ANY
18828: #
18829: movab cfp$f(r9),r9 # point to character
18830: movzbl (r9),r6 # load character
18831: movl r6,r9 # set as parm1
18832: movl $p$ans,r7 # point to pcode for 1-char any
18833: jmp gtpt3 # jump to build node
18834: #
18835: # HERE IF ARGUMENT IS NOT CONVERTIBLE TO STRING
18836: #
18837: gtpt2: movl $p$exa,r7 # set pcode for expression in case
18838: cmpl (r9),$b$e$$ # jump to build node if expression
18839: blequ gtpt3
18840: #
18841: # HERE WE HAVE AN ERROR (CONVERSION IMPOSSIBLE)
18842: #
18843: movl (sp)+,r11 # take convert error exit
18844: jmp *(r11)+
18845: #
18846: # MERGE HERE TO BUILD NODE FOR STRING OR EXPRESSION
18847: #
18848: gtpt3: jsb pbild # call routine to build pattern node
18849: #
18850: # COMMON EXIT AFTER SUCCESSFUL CONVERSION
18851: #
18852: gtpt4: movl gtpsb,r7 # restore wb
18853: #
18854: # MERGE HERE TO EXIT OF NO CONVERSION REQUIRED
18855: #
18856: gtpt5: addl2 $4*1,(sp) # return to gtpat caller
18857: rsb
18858: #enp # end procedure gtpat
18859: #page
18860: #
18861: # GTREA -- GET REAL VALUE
18862: #
18863: # GTREA IS PASSED AN OBJECT AND RETURNS A REAL VALUE
18864: # PERFORMING ANY NECESSARY CONVERSIONS.
18865: #
18866: # (XR) OBJECT TO BE CONVERTED
18867: # JSR GTREA CALL TO CONVERT OBJECT TO REAL
18868: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
18869: # (XR) POINTER TO RESULTING REAL
18870: # (WA,WB,WC,RA) DESTROYED
18871: # (XR) UNCHANGED (CONVERT ERROR ONLY)
18872: #
18873: gtrea: #prc # entry point
18874: movl (r9),r6 # get first word of block
18875: cmpl r6,$b$rcl # jump if real
18876: beqlu gtre2
18877: jsb gtnum # else convert argument to numeric
18878: .long gtre3 # jump if unconvertible
18879: cmpl r6,$b$rcl # jump if real was returned
18880: beqlu gtre2
18881: #
18882: # HERE FOR CASE OF AN INTEGER TO CONVERT TO REAL
18883: #
18884: gtre1: movl 4*icval(r9),r5 # load integer
18885: cvtlf r5,r2 # convert to real
18886: jsb rcbld # build rcblk
18887: #
18888: # EXIT WITH REAL
18889: #
18890: gtre2: addl2 $4*1,(sp) # return to gtrea caller
18891: rsb
18892: #
18893: # HERE ON CONVERSION ERROR
18894: #
18895: gtre3: movl (sp)+,r11 # take convert error exit
18896: jmp *(r11)+
18897: #enp # end procedure gtrea
18898: #page
18899: #
18900: # GTSMI -- GET SMALL INTEGER
18901: #
18902: # GTSMI IS PASSED A SNOBOL OBJECT AND RETURNS AN ADDRESS
18903: # INTEGER IN THE RANGE (0 LE N LE DNAMB). SUCH A VALUE CAN
18904: # ONLY BE DERIVED FROM AN INTEGER IN THE APPROPRIATE RANGE.
18905: # SMALL INTEGERS NEVER APPEAR AS SNOBOL VALUES. HOWEVER,
18906: # THEY ARE USED INTERNALLY FOR A VARIETY OF PURPOSES.
18907: #
18908: # -(XS) ARGUMENT TO CONVERT (ON STACK)
18909: # JSR GTSMI CALL TO CONVERT TO SMALL INTEGER
18910: # PPM LOC TRANSFER LOC FOR NOT INTEGER
18911: # PPM LOC TRANSFER LOC FOR LT 0, GT DNAMB
18912: # (XR,WC) RESULTING SMALL INT (TWO COPIES)
18913: # (XS) POPPED
18914: # (RA) DESTROYED
18915: # (WA,WB) DESTROYED (ON CONVERT ERROR ONLY)
18916: # (XR) INPUT ARG (CONVERT ERROR ONLY)
18917: #
18918: .data 1
18919: gtsmi_s: .long 0
18920: .text 0
18921: gtsmi: movl (sp)+,gtsmi_s # entry point
18922: movl (sp)+,r9 # load argument
18923: cmpl (r9),$b$icl # skip if already an integer
18924: beqlu gtsm1
18925: #
18926: # HERE IF NOT AN INTEGER
18927: #
18928: jsb gtint # convert argument to integer
18929: .long gtsm2 # jump if convert is impossible
18930: #
18931: # MERGE HERE WITH INTEGER
18932: #
18933: gtsm1: movl 4*icval(r9),r5 # load integer value
18934: movl r5,r8 # move as one word, jump if ovflow
18935: bgeq 0f
18936: jmp gtsm3
18937: 0:
18938: cmpl r8,mxlen # or if too small
18939: bgtru gtsm3
18940: movl r8,r9 # copy result to xr
18941: addl3 $4*2,gtsmi_s,r11 # return to gtsmi caller
18942: jmp (r11)
18943: #
18944: # HERE IF UNCONVERTIBLE TO INTEGER
18945: #
18946: gtsm2: movl gtsmi_s,r11 # take non-integer error exit
18947: jmp *(r11)+
18948: #
18949: # HERE IF OUT OF RANGE
18950: #
18951: gtsm3: addl3 $4*1,gtsmi_s,r11 # take out-of-range error exit
18952: jmp *(r11)+
18953: #enp # end procedure gtsmi
18954: #page
18955: #
18956: # GTSTG -- GET STRING
18957: #
18958: # GTSTG IS PASSED AN OBJECT AND RETURNS A STRING WITH
18959: # ANY NECESSARY CONVERSIONS PERFORMED.
18960: #
18961: # -(XS) INPUT ARGUMENT (ON STACK)
18962: # JSR GTSTG CALL TO CONVERT TO STRING
18963: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
18964: # (XR) POINTER TO RESULTING STRING
18965: # (WA) LENGTH OF STRING IN CHARACTERS
18966: # (XS) POPPED
18967: # (RA) DESTROYED
18968: # (XR) INPUT ARG (CONVERT ERROR ONLY)
18969: #
18970: .data 1
18971: gtstg_s: .long 0
18972: .text 0
18973: gtstg: movl (sp)+,gtstg_s # entry point
18974: movl (sp)+,r9 # load argument, pop stack
18975: cmpl (r9),$b$scl # jump if already a string
18976: bnequ 0f
18977: jmp gts30
18978: 0:
18979: #
18980: # HERE IF NOT A STRING ALREADY
18981: #
18982: gts01: movl r9,-(sp) # restack argument in case error
18983: movl r10,-(sp) # save xl
18984: movl r7,gtsvb # save wb
18985: movl r8,gtsvc # save wc
18986: movl (r9),r6 # load first word of block
18987: cmpl r6,$b$icl # jump to convert integer
18988: beqlu gts05
18989: cmpl r6,$b$rcl # jump to convert real
18990: bnequ 0f
18991: jmp gts10
18992: 0:
18993: cmpl r6,$b$nml # jump to convert name
18994: beqlu gts03
18995: cmpl r6,$b$bct # jump to convert buffer
18996: bnequ 0f
18997: jmp gts32
18998: 0:
18999: #
19000: # HERE ON CONVERSION ERROR
19001: #
19002: gts02: movl (sp)+,r10 # restore xl
19003: movl (sp)+,r9 # reload input argument
19004: movl gtstg_s,r11 # take convert error exit
19005: jmp *(r11)+
19006: #page
19007: #
19008: # GTSTG (CONTINUED)
19009: #
19010: # HERE TO CONVERT A NAME (ONLY POSSIBLE IF NATURAL VAR)
19011: #
19012: gts03: movl 4*nmbas(r9),r10 # load name base
19013: cmpl r10,state # error if not natural var (static)
19014: bgequ gts02
19015: addl2 $4*vrsof,r10 # else point to possible string name
19016: movl 4*sclen(r10),r6 # load length
19017: tstl r6 # jump if not system variable
19018: bnequ gts04
19019: movl 4*vrsvo(r10),r10# else point to svblk
19020: movl 4*svlen(r10),r6 # and load name length
19021: #
19022: # MERGE HERE WITH STRING IN XR, LENGTH IN WA
19023: #
19024: gts04: clrl r7 # set offset to zero
19025: jsb sbstr # use sbstr to copy string
19026: jmp gts29 # jump to exit
19027: #
19028: # COME HERE TO CONVERT AN INTEGER
19029: #
19030: gts05: movl 4*icval(r9),r5 # load integer value
19031: movl $num01,gtssf # set sign flag negative
19032: tstl r5 # skip if integer is negative
19033: blss gts06
19034: mnegl r5,r5 # else negate integer
19035: clrl gtssf # and reset negative flag
19036: #page
19037: #
19038: # GTSTG (CONTINUED)
19039: #
19040: # HERE WITH SIGN FLAG SET AND SIGN FORCED NEGATIVE AS
19041: # REQUIRED BY THE CVD INSTRUCTION.
19042: #
19043: gts06: movl gtswk,r9 # point to result work area
19044: movl $nstmx,r7 # initialize counter to max length
19045: movab cfp$f(r9)[r7],r9# prepare to store (right-left)
19046: #
19047: # LOOP TO CONVERT DIGITS INTO WORK AREA
19048: #
19049: gts07: ashq $-32,r4,r4 # convert one digit into wa
19050: ediv $10,r4,r5,r6
19051: mnegl r6,r6
19052: bisb2 $0x30,r6
19053: movb r6,-(r9) # store in work area
19054: decl r7 # decrement counter
19055: tstl r5 # loop if more digits to go
19056: bneq gts07
19057: #csc r9 # complete store characters
19058: #
19059: # MERGE HERE AFTER CONVERTING INTEGER OR REAL INTO WORK
19060: # AREA. WB IS SET TO NSTMX - (NUMBER OF CHARS IN RESULT).
19061: #
19062: gts08: movl $nstmx,r6 # get max number of characters
19063: subl2 r7,r6 # compute length of result
19064: movl r6,r10 # remember length for move later on
19065: addl2 gtssf,r6 # add one for negative sign if needed
19066: jsb alocs # allocate string for result
19067: movl r9,r8 # save result pointer for the moment
19068: movab cfp$f(r9),r9 # point to chars of result block
19069: tstl gtssf # skip if positive
19070: beqlu gts09
19071: movl $ch$mn,r6 # else load negative sign
19072: movb r6,(r9)+ # and store it
19073: #csc r9 # complete store characters
19074: #
19075: # HERE AFTER DEALING WITH SIGN
19076: #
19077: gts09: movl r10,r6 # recall length to move
19078: movl gtswk,r10 # point to result work area
19079: movab cfp$f(r10)[r7],r10 # point to first result character
19080: jsb sbmvc # move chars to result string
19081: movl r8,r9 # restore result pointer
19082: jmp gts29 # jump to exit
19083: #page
19084: #
19085: # GTSTG (CONTINUED)
19086: #
19087: # HERE TO CONVERT A REAL
19088: #
19089: gts10: movf 4*rcval(r9),r2 # load real
19090: clrl gtssf # reset negative flag
19091: tstf r2 # skip if zero
19092: bneq 0f
19093: jmp gts31
19094: 0:
19095: tstf r2 # jump if real is positive
19096: bgeq gts11
19097: movl $num01,gtssf # else set negative flag
19098: mnegf r2,r2 # and get absolute value of real
19099: #
19100: # NOW SCALE THE REAL TO THE RANGE (0.1 LE X LT 1.0)
19101: #
19102: gts11: movl intv0,r5 # initialize exponent to zero
19103: #
19104: # LOOP TO SCALE UP IN STEPS OF 10**10
19105: #
19106: gts12: movf r2,gtsrs # save real value
19107: subf2 reap1,r2 # subtract 0.1 to compare
19108: tstf r2 # jump if scale up not required
19109: bgeq gts13
19110: movf gtsrs,r2 # else reload value
19111: mulf2 reatt,r2 # multiply by 10**10
19112: subl2 intvt,r5 # decrement exponent by 10
19113: jmp gts12 # loop back to test again
19114: #
19115: # TEST FOR SCALE DOWN REQUIRED
19116: #
19117: gts13: movf gtsrs,r2 # reload value
19118: subf2 reav1,r2 # subtract 1.0
19119: tstf r2 # jump if no scale down required
19120: blss gts17
19121: movf gtsrs,r2 # else reload value
19122: #
19123: # LOOP TO SCALE DOWN IN STEPS OF 10**10
19124: #
19125: gts14: subf2 reatt,r2 # subtract 10**10 to compare
19126: tstf r2 # jump if large step not required
19127: blss gts15
19128: movf gtsrs,r2 # else restore value
19129: divf2 reatt,r2 # divide by 10**10
19130: movf r2,gtsrs # store new value
19131: addl2 intvt,r5 # increment exponent by 10
19132: jmp gts14 # loop back
19133: #page
19134: #
19135: # GTSTG (CONTINUED)
19136: #
19137: # AT THIS POINT WE HAVE (1.0 LE X LT 10**10)
19138: # COMPLETE SCALING WITH POWERS OF TEN TABLE
19139: #
19140: gts15: movl $reav1,r9 # point to powers of ten table
19141: #
19142: # LOOP TO LOCATE CORRECT ENTRY IN TABLE
19143: #
19144: gts16: movf gtsrs,r2 # reload value
19145: addl2 intv1,r5 # increment exponent
19146: addl2 $4*cfp$r,r9 # point to next entry in table
19147: subf2 (r9),r2 # subtract it to compare
19148: tstf r2 # loop till we find a larger entry
19149: bgeq gts16
19150: movf gtsrs,r2 # then reload the value
19151: divf2 (r9),r2 # and complete scaling
19152: movf r2,gtsrs # store value
19153: #
19154: # WE ARE NOW SCALED, SO ROUND BY ADDING 0.5 * 10**(-CFP$S)
19155: #
19156: gts17: movf gtsrs,r2 # get value again
19157: addf2 gtsrn,r2 # add rounding factor
19158: movf r2,gtsrs # store result
19159: #
19160: # THE ROUNDING OPERATION MAY HAVE PUSHED US UP PAST
19161: # 1.0 AGAIN, SO CHECK ONE MORE TIME.
19162: #
19163: subf2 reav1,r2 # subtract 1.0 to compare
19164: tstf r2 # skip if ok
19165: blss gts18
19166: addl2 intv1,r5 # else increment exponent
19167: movf gtsrs,r2 # reload value
19168: divf2 reavt,r2 # divide by 10.0 to rescale
19169: jmp gts19 # jump to merge
19170: #
19171: # HERE IF ROUNDING DID NOT MUCK UP SCALING
19172: #
19173: gts18: movf gtsrs,r2 # reload rounded value
19174: #page
19175: #
19176: # GTSTG (CONTINUED)
19177: #
19178: # NOW WE HAVE COMPLETED THE SCALING AS FOLLOWS
19179: #
19180: # (IA) SIGNED EXPONENT
19181: # (RA) SCALED REAL (ABSOLUTE VALUE)
19182: #
19183: # IF THE EXPONENT IS NEGATIVE OR GREATER THAN CFP$S, THEN
19184: # WE CONVERT THE NUMBER IN THE FORM.
19185: #
19186: # (NEG SIGN) 0 . (CPF$S DIGITS) E (EXP SIGN) (EXP DIGITS)
19187: #
19188: # IF THE EXPONENT IS POSITIVE AND LESS THAN OR EQUAL TO
19189: # CFP$S, THE NUMBER IS CONVERTED IN THE FORM.
19190: #
19191: # (NEG SIGN) (EXPONENT DIGITS) . (CFP$S-EXPONENT DIGITS)
19192: #
19193: # IN BOTH CASES, THE FORMATS OBTAINED FROM THE ABOVE
19194: # RULES ARE MODIFIED BY DELETING TRAILING ZEROS AFTER THE
19195: # DECIMAL POINT. THERE ARE NO LEADING ZEROS IN THE EXPONENT
19196: # AND THE EXPONENT SIGN IS ALWAYS PRESENT.
19197: #
19198: gts19: movl $cfp$s,r10 # set num dec digits = cfp$s
19199: movl $ch$mn,gtses # set exponent sign negative
19200: tstl r5 # all set if exponent is negative
19201: blss gts21
19202: movl r5,r6 # else fetch exponent
19203: cmpl r6,$cfp$s # skip if we can use special format
19204: blequ gts20
19205: movl r6,r5 # else restore exponent
19206: mnegl r5,r5 # set negative for cvd
19207: movl $ch$pl,gtses # set plus sign for exponent sign
19208: jmp gts21 # jump to generate exponent
19209: #
19210: # HERE IF WE CAN USE THE FORMAT WITHOUT AN EXPONENT
19211: #
19212: gts20: subl2 r6,r10 # compute digits after decimal point
19213: movl intv0,r5 # reset exponent to zero
19214: #page
19215: #
19216: # GTSTG (CONTINUED)
19217: #
19218: # MERGE HERE AS FOLLOWS
19219: #
19220: # (IA) EXPONENT ABSOLUTE VALUE
19221: # GTSES CHARACTER FOR EXPONENT SIGN
19222: # (RA) POSITIVE FRACTION
19223: # (XL) NUMBER OF DIGITS AFTER DEC POINT
19224: #
19225: gts21: movl gtswk,r9 # point to work area
19226: movl $nstmx,r7 # set character ctr to max length
19227: movab cfp$f(r9)[r7],r9# prepare to store (right to left)
19228: tstl r5 # skip exponent if it is zero
19229: beql gts23
19230: #
19231: # LOOP TO GENERATE DIGITS OF EXPONENT
19232: #
19233: gts22: ashq $-32,r4,r4 # convert a digit into wa
19234: ediv $10,r4,r5,r6
19235: mnegl r6,r6
19236: bisb2 $0x30,r6
19237: movb r6,-(r9) # store in work area
19238: decl r7 # decrement counter
19239: tstl r5 # loop back if more digits to go
19240: bneq gts22
19241: #
19242: # HERE GENERATE EXPONENT SIGN AND E
19243: #
19244: movl gtses,r6 # load exponent sign
19245: movb r6,-(r9) # store in work area
19246: movl $ch$le,r6 # get character letter e
19247: movb r6,-(r9) # store in work area
19248: subl2 $num02,r7 # decrement counter for sign and e
19249: #
19250: # HERE TO GENERATE THE FRACTION
19251: #
19252: gts23: mulf2 gtssc,r2 # convert real to integer (10**cfp$s)
19253: cvtfl r2,r5 # get integer (overflow impossible)
19254: mnegl r5,r5 # negate as required by cvd
19255: #
19256: # LOOP TO SUPPRESS TRAILING ZEROS
19257: #
19258: gts24: tstl r10 # jump if no digits left to do
19259: beqlu gts27
19260: ashq $-32,r4,r4 # else convert one digit
19261: ediv $10,r4,r5,r6
19262: mnegl r6,r6
19263: bisb2 $0x30,r6
19264: cmpl r6,$ch$d0 # jump if not a zero
19265: bnequ gts26
19266: decl r10 # decrement counter
19267: jmp gts24 # loop back for next digit
19268: #page
19269: #
19270: # GTSTG (CONTINUED)
19271: #
19272: # LOOP TO GENERATE DIGITS AFTER DECIMAL POINT
19273: #
19274: gts25: ashq $-32,r4,r4 # convert a digit into wa
19275: ediv $10,r4,r5,r6
19276: mnegl r6,r6
19277: bisb2 $0x30,r6
19278: #
19279: # MERGE HERE FIRST TIME
19280: #
19281: gts26: movb r6,-(r9) # store digit
19282: decl r7 # decrement counter
19283: decl r10 # decrement counter
19284: tstl r10 # loop back if more to go
19285: bnequ gts25
19286: #
19287: # HERE GENERATE THE DECIMAL POINT
19288: #
19289: gts27: movl $ch$dt,r6 # load decimal point
19290: movb r6,-(r9) # store in work area
19291: decl r7 # decrement counter
19292: #
19293: # HERE GENERATE THE DIGITS BEFORE THE DECIMAL POINT
19294: #
19295: gts28: ashq $-32,r4,r4 # convert a digit into wa
19296: ediv $10,r4,r5,r6
19297: mnegl r6,r6
19298: bisb2 $0x30,r6
19299: movb r6,-(r9) # store in work area
19300: decl r7 # decrement counter
19301: tstl r5 # loop back if more to go
19302: bneq gts28
19303: #csc r9 # complete store characters
19304: jmp gts08 # else jump back to exit
19305: #
19306: # EXIT POINT AFTER SUCCESSFUL CONVERSION
19307: #
19308: gts29: movl (sp)+,r10 # restore xl
19309: addl2 $4,sp # pop argument
19310: movl gtsvb,r7 # restore wb
19311: movl gtsvc,r8 # restore wc
19312: #
19313: # MERGE HERE IF NO CONVERSION REQUIRED
19314: #
19315: gts30: movl 4*sclen(r9),r6 # load string length
19316: addl3 $4*1,gtstg_s,r11 # return to caller
19317: jmp (r11)
19318: #
19319: # HERE TO RETURN STRING FOR REAL ZERO
19320: #
19321: gts31: movl $scre0,r10 # point to string
19322: movl $num02,r6 # 2 chars
19323: clrl r7 # zero offset
19324: jsb sbstr # copy string
19325: jmp gts29 # return
19326: #page
19327: #
19328: # HERE TO CONVERT A BUFFER BLOCK
19329: #
19330: gts32: movl r9,r10 # copy arg ptr
19331: movl 4*bclen(r10),r6 # get size to allocate
19332: tstl r6 # if null then return null
19333: beqlu gts33
19334: jsb alocs # allocate string frame
19335: movl r9,r7 # save string ptr
19336: movl 4*sclen(r9),r6 # get length to move
19337: movab 3+(4*0)(r6),r6 # get as multiple of word size
19338: bicl2 $3,r6
19339: movl 4*bcbuf(r10),r10# point to bfblk
19340: addl2 $4*scsi$,r9 # point to start of character area
19341: addl2 $4*bfsi$,r10 # point to start of buffer chars
19342: jsb sbmvw # copy words
19343: movl r7,r9 # restore scblk ptr
19344: jmp gts29 # exit with scblk
19345: #
19346: # HERE WHEN NULL BUFFER IS BEING CONVERTED
19347: #
19348: gts33: movl $nulls,r9 # point to null
19349: jmp gts29 # exit with null
19350: #enp # end procedure gtstg
19351: #page
19352: #
19353: # GTVAR -- GET VARIABLE FOR I/O/TRACE ASSOCIATION
19354: #
19355: # GTVAR IS USED TO POINT TO AN ACTUAL VARIABLE LOCATION
19356: # FOR THE DETACH,INPUT,OUTPUT,TRACE,STOPTR SYSTEM FUNCTIONS
19357: #
19358: # (XR) ARGUMENT TO FUNCTION
19359: # JSR GTVAR CALL TO LOCATE VARIABLE POINTER
19360: # PPM LOC TRANSFER LOC IF NOT OK VARIABLE
19361: # (XL,WA) NAME BASE,OFFSET OF VARIABLE
19362: # (XR,RA) DESTROYED
19363: # (WB,WC) DESTROYED (CONVERT ERROR ONLY)
19364: # (XR) INPUT ARG (CONVERT ERROR ONLY)
19365: #
19366: gtvar: #prc # entry point
19367: cmpl (r9),$b$nml # jump if not a name
19368: bnequ gtvr2
19369: movl 4*nmofs(r9),r6 # else load name offset
19370: movl 4*nmbas(r9),r10 # load name base
19371: cmpl (r10),$b$evt # error if expression variable
19372: beqlu gtvr1
19373: cmpl (r10),$b$kvt # all ok if not keyword variable
19374: bnequ gtvr3
19375: #
19376: # HERE ON CONVERSION ERROR
19377: #
19378: gtvr1: movl (sp)+,r11 # take convert error exit
19379: jmp *(r11)+
19380: #
19381: # HERE IF NOT A NAME, TRY CONVERT TO NATURAL VARIABLE
19382: #
19383: gtvr2: movl r8,gtvrc # save wc
19384: jsb gtnvr # locate vrblk if possible
19385: .long gtvr1 # jump if convert error
19386: movl r9,r10 # else copy vrblk name base
19387: movl $4*vrval,r6 # and set offset
19388: movl gtvrc,r8 # restore wc
19389: #
19390: # HERE FOR NAME OBTAINED
19391: #
19392: gtvr3: cmpl r10,state # all ok if not natural variable
19393: bgequ gtvr4
19394: cmpl 4*vrsto(r10),$b$vre # error if protected variable
19395: beqlu gtvr1
19396: #
19397: # COMMON EXIT POINT
19398: #
19399: gtvr4: addl2 $4*1,(sp) # return to caller
19400: rsb
19401: #enp # end procedure gtvar
19402: #page
19403: #
19404: # HASHS -- COMPUTE HASH INDEX FOR STRING
19405: #
19406: # HASHS IS USED TO CONVERT A STRING TO A UNIQUE INTEGER
19407: # VALUE. THE RESULTING HASH VALUE IS A POSITIVE INTEGER
19408: # IN THE RANGE 0 TO CFP$M
19409: #
19410: # (XR) STRING TO BE HASHED
19411: # JSR HASHS CALL TO HASH STRING
19412: # (IA) HASH VALUE
19413: # (XR,WB,WC) DESTROYED
19414: #
19415: # THE HASH FUNCTION USED IS AS FOLLOWS.
19416: #
19417: # START WITH THE LENGTH OF THE STRING (SGD07)
19418: #
19419: # TAKE THE FIRST E$HNW WORDS OF THE CHARACTERS FROM
19420: # THE STRING OR ALL THE WORDS IF FEWER THAN E$HNW.
19421: #
19422: # COMPUTE THE EXCLUSIVE OR OF ALL THESE WORDS TREATING
19423: # THEM AS ONE WORD BIT STRING VALUES.
19424: #
19425: # MOVE THE RESULT AS AN INTEGER WITH THE MTI INSTRUCTION.
19426: #
19427: hashs: #prc # entry point
19428: movl 4*sclen(r9),r8 # load string length in characters
19429: movl r8,r7 # initialize with length
19430: tstl r8 # jump if null string
19431: beqlu hshs3
19432: movab 3+(4*0)(r8),r8 # else get number of words of chars
19433: ashl $-2,r8,r8
19434: addl2 $4*schar,r9 # point to characters of string
19435: cmpl r8,$e$hnw # use whole string if short
19436: blequ hshs1
19437: movl $e$hnw,r8 # else set to involve first e$hnw wds
19438: #
19439: # HERE WITH COUNT OF WORDS TO CHECK IN WC
19440: #
19441: hshs1: # set counter to control loop
19442: #
19443: # LOOP TO COMPUTE EXCLUSIVE OR
19444: #
19445: hshs2: xorl2 (r9)+,r7 # exclusive or next word of chars
19446: sobgtr r8,hshs2 # loop till all processed
19447: #
19448: # MERGE HERE WITH EXCLUSIVE OR IN WB
19449: #
19450: hshs3: #zgb r7 # zeroise undefined bits
19451: mcoml bitsm,r11 # ensure in range 0 to cfp$m
19452: bicl2 r11,r7
19453: movl r7,r5 # move result as integer
19454: clrl r9 # clear garbage value in xr
19455: rsb # return to hashs caller
19456: #enp # end procedure hashs
19457: #page
19458: #
19459: # ICBLD -- BUILD INTEGER BLOCK
19460: #
19461: # (IA) INTEGER VALUE FOR ICBLK
19462: # JSR ICBLD CALL TO BUILD INTEGER BLOCK
19463: # (XR) POINTER TO RESULT ICBLK
19464: # (WA) DESTROYED
19465: #
19466: icbld: #prc # entry point
19467: movl r5,r9 # copy small integers
19468: bgeq 0f
19469: jmp icbl1
19470: 0:
19471: cmpl r9,$num02 # jump if 0,1 or 2
19472: blequ icbl3
19473: #
19474: # CONSTRUCT ICBLK
19475: #
19476: icbl1: movl dnamp,r9 # load pointer to next available loc
19477: addl2 $4*icsi$,r9 # point past new icblk
19478: cmpl r9,dname # jump if there is room
19479: blequ icbl2
19480: movl $4*icsi$,r6 # else load length of icblk
19481: jsb alloc # use standard allocator to get block
19482: addl2 r6,r9 # point past block to merge
19483: #
19484: # MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
19485: #
19486: icbl2: movl r9,dnamp # set new pointer
19487: subl2 $4*icsi$,r9 # point back to start of block
19488: movl $b$icl,(r9) # store type word
19489: movl r5,4*icval(r9) # store integer value in icblk
19490: rsb # return to icbld caller
19491: #
19492: # OPTIMISE BY NOT BUILDING ICBLKS FOR SMALL INTEGERS
19493: #
19494: icbl3: moval 0[r9],r9 # convert integer to offset
19495: movl l^intab(r9),r9 # point to pre-built icblk
19496: rsb # return
19497: #enp # end procedure icbld
19498: #page
19499: #
19500: # IDENT -- COMPARE TWO VALUES
19501: #
19502: # IDENT COMPARES TWO VALUES IN THE SENSE OF THE IDENT
19503: # DIFFER FUNCTIONS AVAILABLE AT THE SNOBOL LEVEL.
19504: #
19505: # (XR) FIRST ARGUMENT
19506: # (XL) SECOND ARGUMENT
19507: # JSR IDENT CALL TO COMPARE ARGUMENTS
19508: # PPM LOC TRANSFER LOC IF IDENT
19509: # (NORMAL RETURN IF DIFFER)
19510: # (XR,XL,WC,RA) DESTROYED
19511: #
19512: ident: #prc # entry point
19513: cmpl r9,r10 # jump if same pointer (ident)
19514: bnequ 0f
19515: jmp iden7
19516: 0:
19517: movl (r9),r8 # else load arg 1 type word
19518: cmpl r8,(r10) # differ if arg 2 type word differ
19519: bnequ iden1
19520: cmpl r8,$b$scl # jump if strings
19521: beqlu iden2
19522: cmpl r8,$b$icl # jump if integers
19523: beqlu iden4
19524: cmpl r8,$b$rcl # jump if reals
19525: beqlu iden5
19526: cmpl r8,$b$nml # jump if names
19527: beqlu iden6
19528: #
19529: # FOR ALL OTHER DATATYPES, MUST BE DIFFER IF XR NE XL
19530: #
19531: # MERGE HERE FOR DIFFER
19532: #
19533: iden1: addl2 $4*1,(sp) # take differ exit
19534: rsb
19535: #
19536: # HERE FOR STRINGS, IDENT ONLY IF LENGTHS AND CHARS SAME
19537: #
19538: iden2: movl 4*sclen(r9),r8 # load arg 1 length
19539: cmpl r8,4*sclen(r10) # differ if lengths differ
19540: bnequ iden1
19541: movab 3+(4*0)(r8),r8 # get number of words in strings
19542: ashl $-2,r8,r8
19543: addl2 $4*schar,r9 # point to chars of arg 1
19544: addl2 $4*schar,r10 # point to chars of arg 2
19545: # set loop counter
19546: #
19547: # LOOP TO COMPARE CHARACTERS. NOTE THAT WA CANNOT BE ZERO
19548: # SINCE ALL NULL STRINGS POINT TO NULLS AND GIVE XL=XR.
19549: #
19550: iden3: cmpl (r9),(r10) # differ if chars do not match
19551: bnequ iden8
19552: addl2 $4,r9 # else bump arg one pointer
19553: addl2 $4,r10 # bump arg two pointer
19554: sobgtr r8,iden3 # loop back till all checked
19555: #page
19556: #
19557: # IDENT (CONTINUED)
19558: #
19559: # HERE TO EXIT FOR CASE OF TWO IDENT STRINGS
19560: #
19561: clrl r10 # clear garbage value in xl
19562: clrl r9 # clear garbage value in xr
19563: movl (sp)+,r11 # take ident exit
19564: jmp *(r11)+
19565: #
19566: # HERE FOR INTEGERS, IDENT IF SAME VALUES
19567: #
19568: iden4: movl 4*icval(r9),r5 # load arg 1
19569: subl2 4*icval(r10),r5 # subtract arg 2 to compare
19570: bvs iden1
19571: tstl r5 # differ if result is not zero
19572: bneq iden1
19573: movl (sp)+,r11 # take ident exit
19574: jmp *(r11)+
19575: #
19576: # HERE FOR REALS, IDENT IF SAME VALUES
19577: #
19578: iden5: movf 4*rcval(r9),r2 # load arg 1
19579: subf2 4*rcval(r10),r2 # subtract arg 2 to compare
19580: bvs iden1
19581: tstf r2 # differ if result is not zero
19582: bneq iden1
19583: movl (sp)+,r11 # take ident exit
19584: jmp *(r11)+
19585: #
19586: # HERE FOR NAMES, IDENT IF BASES AND OFFSETS SAME
19587: #
19588: iden6: cmpl 4*nmofs(r9),4*nmofs(r10) # differ if different offset
19589: bnequ iden1
19590: cmpl 4*nmbas(r9),4*nmbas(r10) # differ if different base
19591: bnequ iden1
19592: #
19593: # MERGE HERE TO SIGNAL IDENT FOR IDENTICAL POINTERS
19594: #
19595: iden7: movl (sp)+,r11 # take ident exit
19596: jmp *(r11)+
19597: #
19598: # HERE FOR DIFFER STRINGS
19599: #
19600: iden8: clrl r9 # clear garbage ptr in xr
19601: clrl r10 # clear garbage ptr in xl
19602: addl2 $4*1,(sp) # return to caller (differ)
19603: rsb
19604: #enp # end procedure ident
19605: #page
19606: #
19607: # INOUT - USED TO INITIALISE INPUT AND OUTPUT VARIABLES
19608: #
19609: # (XL) POINTER TO VBL NAME STRING
19610: # (WB) TRBLK TYPE
19611: # JSR INOUT CALL TO PERFORM INITIALISATION
19612: # (XL) VRBLK PTR
19613: # (XR) TRBLK PTR
19614: # (WA,WC) DESTROYED
19615: #
19616: # NOTE THAT TRTER (= TRTRF) FIELD OF STANDARD I/O VARIABLES
19617: # POINTS TO CORRESPONDING SVBLK NOT TO A TRBLK AS IS THE
19618: # CASE FOR ORDINARY VARIABLES.
19619: #
19620: inout: #prc # entry point
19621: movl r7,-(sp) # stack trblk type
19622: movl 4*sclen(r10),r6 # get name length
19623: clrl r7 # point to start of name
19624: jsb sbstr # build a proper scblk
19625: jsb gtnvr # build vrblk
19626: .long invalid$ # no error return
19627: movl r9,r8 # save vrblk pointer
19628: movl (sp)+,r7 # get trter field
19629: clrl r10 # zero trfpt
19630: jsb trbld # build trblk
19631: movl r8,r10 # recall vrblk pointer
19632: movl 4*vrsvp(r10),4*trter(r9) # store svblk pointer
19633: movl r9,4*vrval(r10) # store trblk ptr in vrblk
19634: movl $b$vra,4*vrget(r10) # set trapped access
19635: movl $b$vrv,4*vrsto(r10) # set trapped store
19636: rsb # return to caller
19637: #enp # end procedure inout
19638: #page
19639: #
19640: # INSBF -- INSERT STRING IN BUFFER
19641: #
19642: # THIS ROUTINE WILL REPLACE A SECTION OF A BUFFER WITH THE
19643: # CONTENTS OF A GIVEN STRING. IF THE LENGTH OF THE
19644: # SECTION TO BE REPLACED IS DIFFERENT THAN THE LENGTH OF
19645: # THE GIVEN STRING, AND THE REPLACEMENT IS NOT AN APPEND,
19646: # THEN THE UPPER SECTION OF THE BUFFER IS SHIFTED UP OR
19647: # DOWN TO CREATE THE PROPER SPACE FOR THE INSERT.
19648: #
19649: # (XR) POINTER TO BFBLK
19650: # (XL) OBJECT WHICH IS STRING CONVERTABLE
19651: # (WA) OFFSET OF START OF INSERT IN (XR)
19652: # (WB) LENGTH OF SECTION IN (XR) REPLACED
19653: # JSR INSBF CALL TO INSERT CHARACTERS IN BUFFER
19654: # PPM LOC THREAD IF (XR) NOT CONVERTABLE
19655: # PPM LOC THREAD IF INSERT NOT POSSIBLE
19656: #
19657: # THE SECOND ALTERNATE EXIT IS TAKEN IF THE INSERT WOULD
19658: # OVERFLOW THE BUFFER, OR IF THE INSERT IS OUT PAST THE
19659: # DEFINED END OF THE BUFFER AS GIVEN.
19660: #
19661: insbf: #prc # entry point
19662: movl r6,inssa # save entry wa
19663: movl r7,inssb # save entry wb
19664: movl r8,inssc # save entry wc
19665: addl2 r7,r6 # add to get offset past replace part
19666: movl r6,insab # save wa+wb
19667: movl 4*bclen(r9),r8 # get current defined length
19668: cmpl inssa,r8 # fail if start offset too big
19669: blequ 0f
19670: jmp ins07
19671: 0:
19672: cmpl r6,r8 # fail if final offset too big
19673: blequ 0f
19674: jmp ins07
19675: 0:
19676: movl r10,-(sp) # save entry xl
19677: movl r9,-(sp) # save bcblk ptr
19678: movl r10,-(sp) # stack again for gtstg
19679: jsb gtstg # call to convert to string
19680: .long ins05 # take string convert err exit
19681: movl r9,r10 # save string ptr
19682: movl (sp),r9 # restore bcblk ptr
19683: addl2 r8,r6 # add buffer len to string len
19684: subl2 inssb,r6 # bias out component being replaced
19685: movl 4*bcbuf(r9),r9 # point to bfblk
19686: cmpl r6,4*bfalc(r9) # fail if result exceeds allocation
19687: blequ 0f
19688: jmp ins06
19689: 0:
19690: movl (sp),r9 # restore bcblk ptr
19691: movl r8,r6 # get buffer length
19692: subl2 insab,r6 # subtract to get shift length
19693: addl2 4*sclen(r10),r8 # add length of new
19694: subl2 inssb,r8 # subtract old to get total new len
19695: movl 4*bclen(r9),r7 # get old bclen
19696: movl r8,4*bclen(r9) # stuff new length
19697: tstl r6 # skip shift if nothing to do
19698: bnequ 0f
19699: jmp ins04
19700: 0:
19701: cmpl inssb,4*sclen(r10) # skip shift if lengths match
19702: bnequ 0f
19703: jmp ins04
19704: 0:
19705: movl 4*bcbuf(r9),r9 # point to bfblk
19706: movl r10,-(sp) # save scblk ptr
19707: cmpl inssb,4*sclen(r10) # brn if shft is for more room
19708: blequ ins01
19709: #page
19710: #
19711: # INSBF (CONTINUED)
19712: #
19713: # WE ARE SHIFTING THE UPPER SEGMENT DOWN TO COMPACT
19714: # THE BUFFER. (THE STRING LENGTH IS SMALLER THAN THE
19715: # SEGMENT BEING REPLACED.) REGISTERS ARE SET AS:
19716: #
19717: # (WA) MOVE (SHIFT DOWN) LENGTH
19718: # (WB) OLD BCLEN
19719: # (WC) NEW BCLEN
19720: # (XR) BFBLK PTR
19721: # (XL),(XS) SCBLK PTR
19722: #
19723: movl inssa,r7 # get offset to insert
19724: addl2 4*sclen(r10),r7 # add insert length to get dest off
19725: movl r9,r10 # make copy
19726: movl insab,r11 # [get in scratch register]
19727: movab cfp$f(r10)[r11],r10 # prepare source for move
19728: movab cfp$f(r9)[r7],r9# prepare destination reg for move
19729: jsb sbmvc # move em out
19730: jmp ins02 # branch to pad
19731: #
19732: # WE ARE SHIFTING THE UPPER SEGMENT UP TO EXPAND
19733: # THE BUFFER. (THE STRING LENGTH IS LARGER THAN THE
19734: # SEGMENT BEING REPLACED.)
19735: #
19736: ins01: movl r9,r10 # copy bfblk ptr
19737: movab cfp$f(r10)[r7],r10 # set source reg for move backwards
19738: movab cfp$f(r9)[r8],r9# set destination ptr for move
19739: jsb sbmcb # move backwards (possible overlap)
19740: #
19741: # MERGE HERE AFTER MOVE TO ADJUST PADDING AT NEW BUFFER END
19742: #
19743: ins02: movl (sp)+,r10 # restore scblk ptr
19744: movl r8,r6 # copy new buffer end
19745: movab 3+(4*0)(r6),r6 # round out
19746: bicl2 $3,r6
19747: subl2 r8,r6 # subtract to get remainder
19748: tstl r6 # no pad if already even boundary
19749: bnequ 0f
19750: jmp ins04
19751: 0:
19752: movl (sp),r9 # get bcblk ptr
19753: movl 4*bcbuf(r9),r9 # get bfblk ptr
19754: movab cfp$f(r9)[r8],r9# prepare to pad
19755: clrl r7 # clear wb
19756: # load loop count
19757: #
19758: # LOOP HERE TO STUFF PAD CHARACTERS
19759: #
19760: ins03: movb r7,(r9)+ # stuff zero pad
19761: sobgtr r6,ins03 # branch for more
19762: #page
19763: #
19764: # INSBF (CONTINUED)
19765: #
19766: # MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT
19767: # STRING TO THE HOLE.
19768: #
19769: ins04: movl (sp),r9 # get bcblk ptr
19770: movl 4*bcbuf(r9),r9 # get bfblk ptr
19771: movl 4*sclen(r10),r6 # get move length
19772: movab cfp$f(r10),r10 # prepare to copy from first char
19773: movl inssa,r11 # [get in scratch register]
19774: movab cfp$f(r9)[r11],r9# prepare to store in hole
19775: jsb sbmvc # copy the characters
19776: movl (sp)+,r9 # restore entry xr
19777: movl (sp)+,r10 # restore entry xl
19778: movl inssa,r6 # restore entry wa
19779: movl inssb,r7 # restore entry wb
19780: movl inssc,r8 # restore entry wc
19781: addl2 $4*2,(sp) # return to caller
19782: rsb
19783: #
19784: # HERE TO TAKE STRING CONVERT ERROR EXIT
19785: #
19786: ins05: movl (sp)+,r9 # restore entry xr
19787: movl (sp)+,r10 # restore entry xl
19788: movl inssa,r6 # restore entry wa
19789: movl inssb,r7 # restore entry wb
19790: movl inssc,r8 # restore entry wc
19791: movl (sp)+,r11 # alternate exit
19792: jmp *(r11)+
19793: #
19794: # HERE FOR INVALID OFFSET OR LENGTH
19795: #
19796: ins06: movl (sp)+,r9 # restore entry xr
19797: movl (sp)+,r10 # restore entry xl
19798: #
19799: # MERGE FOR LENGTH FAILURE EXIT WITH STACK SET
19800: #
19801: ins07: movl inssa,r6 # restore entry wa
19802: movl inssb,r7 # restore entry wb
19803: movl inssc,r8 # restore entry wc
19804: addl3 $4*1,(sp)+,r11 # alternate exit
19805: jmp *(r11)+
19806: #enp # end procedure insbf
19807: #page
19808: #
19809: # IOFCB -- GET INPUT/OUTPUT FCBLK POINTER
19810: #
19811: # USED BY ENDFILE, EJECT AND REWIND TO FIND THE FCBLK
19812: # (IF ANY) CORRESPONDING TO THEIR ARGUMENT.
19813: #
19814: # -(XS) ARGUMENT
19815: # JSR IOFCB CALL TO FIND FCBLK
19816: # PPM LOC ARG IS AN UNSUITABLE NAME
19817: # PPM LOC ARG IS NULL STRING
19818: # (XS) POPPED
19819: # (XL) PTR TO FILEARG1 VRBLK
19820: # (XR) ARGUMENT
19821: # (WA) FCBLK PTR OR 0
19822: # (WB) DESTROYED
19823: #
19824: .data 1
19825: iofcb_s: .long 0
19826: .text 0
19827: iofcb: movl (sp)+,iofcb_s # entry point
19828: jsb gtstg # get arg as string
19829: .long iofc2 # fail
19830: movl r9,r10 # copy string ptr
19831: jsb gtnvr # get as natural variable
19832: .long iofc3 # fail if null
19833: movl r10,r7 # copy string pointer again
19834: movl r9,r10 # copy vrblk ptr for return
19835: clrl r6 # in case no trblk found
19836: #
19837: # LOOP TO FIND FILE ARG1 TRBLK
19838: #
19839: iofc1: movl 4*vrval(r9),r9 # get possible trblk ptr
19840: cmpl (r9),$b$trt # fail if end of chain
19841: bnequ iofc2
19842: cmpl 4*trtyp(r9),$trtfc # loop if not file arg trblk
19843: bnequ iofc1
19844: movl 4*trfpt(r9),r6 # get fcblk ptr
19845: movl r7,r9 # copy arg
19846: addl3 $4*2,iofcb_s,r11 # return
19847: jmp (r11)
19848: #
19849: # FAIL RETURN
19850: #
19851: iofc2: movl iofcb_s,r11 # fail
19852: jmp *(r11)+
19853: #
19854: # NULL ARG
19855: #
19856: iofc3: addl3 $4*1,iofcb_s,r11 # null arg return
19857: jmp *(r11)+
19858: #enp # end procedure iofcb
19859: #page
19860: #
19861: # IOPPF -- PROCESS FILEARG2 FOR IOPUT
19862: #
19863: # (R$XSC) FILEARG2 PTR
19864: # JSR IOPPF CALL TO PROCESS FILEARG2
19865: # (XL) FILEARG1 PTR
19866: # (XR) FILE ARG2 PTR
19867: # -(XS)..-(XS) FIELDS EXTRACTED FROM FILEARG2
19868: # (WC) NO. OF FIELDS EXTRACTED
19869: # (WB) INPUT/OUTPUT FLAG
19870: # (WA) FCBLK PTR OR 0
19871: #
19872: .data 1
19873: ioppf_s: .long 0
19874: .text 0
19875: ioppf: movl (sp)+,ioppf_s # entry point
19876: clrl r7 # to count fields extracted
19877: #
19878: # LOOP TO EXTRACT FIELDS
19879: #
19880: iopp1: movl $iodel,r10 # get delimiter
19881: movl r10,r8 # copy it
19882: jsb xscan # get next field
19883: movl r9,-(sp) # stack it
19884: incl r7 # increment count
19885: tstl r6 # loop
19886: bnequ iopp1
19887: movl r7,r8 # count of fields
19888: movl ioptt,r7 # i/o marker
19889: movl r$iof,r6 # fcblk ptr or 0
19890: movl r$io2,r9 # file arg2 ptr
19891: movl r$io1,r10 # filearg1
19892: jmp *ioppf_s # return
19893: #enp # end procedure ioppf
19894: #page
19895: #
19896: # IOPUT -- ROUTINE USED BY INPUT AND OUTPUT
19897: #
19898: # IOPUT SETS UP INPUT/OUTPUT ASSOCIATIONS. IT BUILDS
19899: # SUCH TRACE AND FILE CONTROL BLOCKS AS ARE NECESSARY AND
19900: # CALLS SYSFC,SYSIO TO PERFORM CHECKS ON THE
19901: # ARGUMENTS AND TO OPEN THE FILES.
19902: #
19903: # +-----------+ +---------------+ +-----------+
19904: # +-.I I I I------.I =B$XRT I
19905: # I +-----------+ +---------------+ +-----------+
19906: # I / / (R$FCB) I *4 I
19907: # I / / +-----------+
19908: # I +-----------+ +---------------+ I I-
19909: # I I NAME +--.I =B$TRT I +-----------+
19910: # I / / +---------------+ I I
19911: # I (FIRST ARG) I =TRTIN/=TRTOU I +-----------+
19912: # I +---------------+ I
19913: # I I VALUE I I
19914: # I +---------------+ I
19915: # I I(TRTRF) 0 OR I--+ I
19916: # I +---------------+ I I
19917: # I I(TRFPT) 0 OR I----+ I
19918: # I +---------------+ I I I
19919: # I (I/O TRBLK) I I I
19920: # I +-----------+ I I I
19921: # I I I I I I
19922: # I +-----------+ I I I
19923: # I I I I I I
19924: # I +-----------+ +---------------+ I I I
19925: # I I +--.I =B$TRT I.-+ I I
19926: # I +-----------+ +---------------+ I I
19927: # I / / I =TRTFC I I I
19928: # I / / +---------------+ I I
19929: # I (FILEARG1 I VALUE I I I
19930: # I VRBLK) +---------------+ I I
19931: # I I(TRTRF) 0 OR I--+ I .
19932: # I +---------------+ I . +-----------+
19933: # I I(TRFPT) 0 OR I------./ FCBLK /
19934: # I +---------------+ I +-----------+
19935: # I (TRTRF) I
19936: # I I
19937: # I I
19938: # I +---------------+ I
19939: # I I =B$XRT I.-+
19940: # I +---------------+
19941: # I I *5 I
19942: # I +---------------+
19943: # +------------------I I
19944: # +---------------+ +-----------+
19945: # I(TRTRF) O OR I------.I =B$XRT I
19946: # +---------------+ +-----------+
19947: # I NAME OFFSET I I ETC I
19948: # +---------------+
19949: # (IOCHN - CHAIN OF NAME POINTERS)
19950: #page
19951: #
19952: # IOPUT (CONTINUED)
19953: #
19954: # NO ADDITIONAL TRAP BLOCKS ARE USED FOR STANDARD INPUT/OUT
19955: # FILES. OTHERWISE AN I/O TRAP BLOCK IS ATTACHED TO SECOND
19956: # ARG (FILEARG1) VRBLK. SEE DIAGRAM ABOVE FOR DETAILS OF
19957: # THE STRUCTURE BUILT.
19958: #
19959: # -(XS) 1ST ARG (VBL TO BE ASSOCIATED)
19960: # -(XS) 2ND ARG (FILE ARG1)
19961: # -(XS) 3RD ARG (FILE ARG2)
19962: # (WB) 0 FOR INPUT, 3 FOR OUTPUT ASSOC.
19963: # JSR IOPUT CALL FOR INPUT/OUTPUT ASSOCIATION
19964: # PPM LOC 3RD ARG NOT A STRING
19965: # PPM LOC 2ND ARG NOT A SUITABLE NAME
19966: # PPM LOC 1ST ARG NOT A SUITABLE NAME
19967: # PPM LOC INAPPROPRIATE FILE SPEC FOR I/O
19968: # PPM LOC I/O FILE DOES NOT EXIST
19969: # PPM LOC I/O FILE CANNOT BE READ/WRITTEN
19970: # (XS) POPPED
19971: # (XL,XR,WA,WB,WC) DESTROYED
19972: #
19973: .data 1
19974: ioput_s: .long 0
19975: .text 0
19976: ioput: movl (sp)+,ioput_s # entry point
19977: clrl r$iot # in case no trtrf block used
19978: clrl r$iof # in case no fcblk alocated
19979: movl r7,ioptt # store i/o trace type
19980: jsb xscni # prepare to scan filearg2
19981: .long iop13 # fail
19982: .long iopa0 # null file arg2
19983: #
19984: iopa0: movl r9,r$io2 # keep file arg2
19985: movl r6,r10 # copy length
19986: jsb gtstg # convert filearg1 to string
19987: .long iop14 # fail
19988: movl r9,r$io1 # keep filearg1 ptr
19989: jsb gtnvr # convert to natural variable
19990: .long iop00 # jump if null
19991: jmp iop04 # jump to process non-null args
19992: #
19993: # NULL FILEARG1
19994: #
19995: iop00: tstl r10 # skip if both args null
19996: bnequ 0f
19997: jmp iop01
19998: 0:
19999: jsb ioppf # process filearg2
20000: jsb sysfc # call for filearg2 check
20001: .long iop16 # fail
20002: jmp iop11 # complete file association
20003: #page
20004: #
20005: # IOPUT (CONTINUED)
20006: #
20007: # HERE WITH 0 OR FCBLK PTR IN (XL)
20008: #
20009: iop01: movl ioptt,r7 # get trace type
20010: movl r$iot,r9 # get 0 or trtrf ptr
20011: jsb trbld # build trblk
20012: movl r9,r8 # copy trblk pointer
20013: movl (sp)+,r9 # get variable from stack
20014: jsb gtvar # point to variable
20015: .long iop15 # fail
20016: movl r10,r$ion # save name pointer
20017: movl r10,r9 # copy name pointer
20018: addl2 r6,r9 # point to variable
20019: subl2 $4*vrval,r9 # subtract offset,merge into loop
20020: #
20021: # LOOP TO END OF TRBLK CHAIN IF ANY
20022: #
20023: iop02: movl r9,r10 # copy blk ptr
20024: movl 4*vrval(r9),r9 # load ptr to next trblk
20025: cmpl (r9),$b$trt # jump if not trapped
20026: bnequ iop03
20027: cmpl 4*trtyp(r9),ioptt# loop if not same assocn
20028: bnequ iop02
20029: movl 4*trnxt(r9),r9 # get value and delete old trblk
20030: #
20031: # IOPUT (CONTINUED)
20032: #
20033: # STORE NEW ASSOCIATION
20034: #
20035: iop03: movl r8,4*vrval(r10) # link to this trblk
20036: movl r8,r10 # copy pointer
20037: movl r9,4*trnxt(r10) # store value in trblk
20038: movl r$ion,r9 # restore possible vrblk pointer
20039: movl r6,r7 # keep offset to name
20040: jsb setvr # if vrblk, set vrget,vrsto
20041: movl r$iot,r9 # get 0 or trtrf ptr
20042: tstl r9 # jump if trtrf block exists
20043: beqlu 0f
20044: jmp iop19
20045: 0:
20046: addl3 $4*6,ioput_s,r11 # return to caller
20047: jmp (r11)
20048: #
20049: # NON STANDARD FILE
20050: # SEE IF AN FCBLK HAS ALREADY BEEN ALLOCATED.
20051: #
20052: iop04: clrl r6 # in case no fcblk found
20053: #page
20054: #
20055: # IOPUT (CONTINUED)
20056: #
20057: # SEARCH POSSIBLE TRBLK CHAIN TO PICK UP THE FCBLK
20058: #
20059: iop05: movl r9,r7 # remember blk ptr
20060: movl 4*vrval(r9),r9 # chain along
20061: cmpl (r9),$b$trt # jump if end of trblk chain
20062: bnequ iop06
20063: cmpl 4*trtyp(r9),$trtfc # loop if more to go
20064: bnequ iop05
20065: movl r9,r$iot # point to file arg1 trblk
20066: movl 4*trfpt(r9),r6 # get fcblk ptr from trblk
20067: #
20068: # WA = 0 OR FCBLK PTR
20069: # WB = PTR TO PRECEDING BLK TO WHICH ANY TRTRF BLOCK
20070: # FOR FILE ARG1 MUST BE CHAINED.
20071: #
20072: iop06: movl r6,r$iof # keep possible fcblk ptr
20073: movl r7,r$iop # keep preceding blk ptr
20074: jsb ioppf # process filearg2
20075: jsb sysfc # see if fcblk required
20076: .long iop16 # fail
20077: tstl r6 # skip if no new fcblk wanted
20078: bnequ 0f
20079: jmp iop12
20080: 0:
20081: cmpl r8,$num02 # jump if fcblk in dynamic
20082: blssu iop6a
20083: jsb alost # get it in static
20084: jmp iop6b # skip
20085: #
20086: # OBTAIN FCBLK IN DYNAMIC
20087: #
20088: iop6a: jsb alloc # get space for fcblk
20089: #
20090: # MERGE
20091: #
20092: iop6b: movl r9,r10 # point to fcblk
20093: movl r6,r7 # copy its length
20094: ashl $-2,r7,r7 # get count as words (sgd apr80)
20095: # loop counter
20096: #
20097: # CLEAR FCBLK
20098: #
20099: iop07: clrl (r9)+ # clear a word
20100: sobgtr r7,iop07 # loop
20101: cmpl r8,$num02 # skip if in static - dont set fields
20102: bnequ 0f
20103: jmp iop09
20104: 0:
20105: movl $b$xnt,(r10) # store xnblk code in case
20106: movl r6,4*1(r10) # store length
20107: tstl r8 # jump if xnblk wanted
20108: beqlu 0f
20109: jmp iop09
20110: 0:
20111: movl $b$xrt,(r10) # xrblk code requested
20112: #
20113: #page
20114: # IOPUT (CONTINUED)
20115: #
20116: # COMPLETE FCBLK INITIALISATION
20117: #
20118: iop09: movl r$iot,r9 # get possible trblk ptr
20119: movl r10,r$iof # store fcblk ptr
20120: tstl r9 # jump if trblk already found
20121: bnequ iop10
20122: #
20123: # A NEW TRBLK IS NEEDED
20124: #
20125: movl $trtfc,r7 # trtyp for fcblk trap blk
20126: jsb trbld # make the block
20127: movl r9,r$iot # copy trtrf ptr
20128: movl r$iop,r10 # point to preceding blk
20129: movl 4*vrval(r10),4*vrval(r9) # copy value field to trblk
20130: movl r9,4*vrval(r10) # link new trblk into chain
20131: movl r10,r9 # point to predecessor blk
20132: jsb setvr # set trace intercepts
20133: movl 4*vrval(r9),r9 # recover trblk ptr
20134: #
20135: # XR IS PTR TO TRBLK, XL IS FCBLK PTR OR 0
20136: #
20137: iop10: movl r$iof,4*trfpt(r9)# store fcblk ptr
20138: #
20139: # CALL SYSIO TO COMPLETE FILE ACCESSING
20140: #
20141: iop11: movl r$iof,r6 # copy fcblk ptr or 0
20142: movl ioptt,r7 # get input/output flag
20143: movl r$io2,r9 # get file arg2
20144: movl r$io1,r10 # get file arg1
20145: jsb sysio # associate to the file
20146: .long iop17 # fail
20147: .long iop18 # fail
20148: tstl r$iot # not std input if non-null trtrf blk
20149: beqlu 0f
20150: jmp iop01
20151: 0:
20152: tstl ioptt # jump if output
20153: beqlu 0f
20154: jmp iop01
20155: 0:
20156: tstl r8 # no change to standard read length
20157: bnequ 0f
20158: jmp iop01
20159: 0:
20160: movl r8,cswin # store new read length for std file
20161: jmp iop01 # merge to finish the task
20162: #
20163: # SYSFC MAY HAVE RETURNED A POINTER TO A PRIVATE FCBLK
20164: #
20165: iop12: tstl r10 # jump if private fcblk
20166: beqlu 0f
20167: jmp iop09
20168: 0:
20169: jmp iop11 # finish the association
20170: #
20171: # FAILURE RETURNS
20172: #
20173: iop13: movl ioput_s,r11 # 3rd arg not a string
20174: jmp *(r11)+
20175: iop14: addl3 $4*1,ioput_s,r11 # 2nd arg unsuitable
20176: jmp *(r11)+
20177: iop15: addl3 $4*2,ioput_s,r11 # 1st arg unsuitable
20178: jmp *(r11)+
20179: iop16: addl3 $4*3,ioput_s,r11 # file spec wrong
20180: jmp *(r11)+
20181: iop17: addl3 $4*4,ioput_s,r11 # i/o file does not exist
20182: jmp *(r11)+
20183: iop18: addl3 $4*5,ioput_s,r11 # i/o file cannot be read/written
20184: jmp *(r11)+
20185: #page
20186: #
20187: # IOPUT (CONTINUED)
20188: #
20189: # ADD TO IOCHN CHAIN OF ASSSOCIATED VARIABLES UNLESS ALREAD
20190: # PRESENT.
20191: #
20192: iop19: movl r$ion,r8 # wc = name base, wb = name offset
20193: #
20194: # SEARCH LOOP
20195: #
20196: iop20: movl 4*trtrf(r9),r9 # next link of chain
20197: tstl r9 # not found
20198: beqlu iop21
20199: cmpl r8,4*ionmb(r9) # no match
20200: bnequ iop20
20201: cmpl r7,4*ionmo(r9) # exit if matched
20202: beqlu iop22
20203: jmp iop20 # loop
20204: #
20205: # NOT FOUND
20206: #
20207: iop21: movl $4*num05,r6 # space needed
20208: jsb alloc # get it
20209: movl $b$xrt,(r9) # store xrblk code
20210: movl r6,4*1(r9) # store length
20211: movl r8,4*ionmb(r9) # store name base
20212: movl r7,4*ionmo(r9) # store name offset
20213: movl r$iot,r10 # point to trtrf blk
20214: movl 4*trtrf(r10),r6 # get ptr field contents
20215: movl r9,4*trtrf(r10) # store ptr to new block
20216: movl r6,4*trtrf(r9) # complete the linking
20217: #
20218: # INSERT FCBLK ON FCBLK CHAIN FOR SYSEJ, SYSXI
20219: #
20220: iop22: tstl r$iof # skip if no fcblk
20221: beqlu iop25
20222: movl r$fcb,r10 # ptr to head of existing chain
20223: #
20224: # SEE IF FCBLK ALREADY ON CHAIN
20225: #
20226: iop23: tstl r10 # not on if end of chain
20227: beqlu iop24
20228: cmpl 4*3(r10),r$iof # dont duplicate if find it
20229: beqlu iop25
20230: movl 4*2(r10),r10 # get next link
20231: jmp iop23 # loop
20232: #
20233: # NOT FOUND SO ADD AN ENTRY FOR THIS FCBLK
20234: #
20235: iop24: movl $4*num04,r6 # space needed
20236: jsb alloc # get it
20237: movl $b$xrt,(r9) # store block code
20238: movl r6,4*1(r9) # store length
20239: movl r$fcb,4*2(r9) # store previous link in this node
20240: movl r$iof,4*3(r9) # store fcblk ptr
20241: movl r9,r$fcb # insert node into fcblk chain
20242: #
20243: # RETURN
20244: #
20245: iop25: addl3 $4*6,ioput_s,r11 # return to caller
20246: jmp (r11)
20247: #enp # end procedure ioput
20248: #page
20249: #
20250: # KTREX -- EXECUTE KEYWORD TRACE
20251: #
20252: # KTREX IS USED TO EXECUTE A POSSIBLE KEYWORD TRACE. IT
20253: # INCLUDES THE TEST ON TRACE AND TESTS FOR TRACE ACTIVE.
20254: #
20255: # (XL) PTR TO TRBLK (OR 0 IF UNTRACED)
20256: # JSR KTREX CALL TO EXECUTE KEYWORD TRACE
20257: # (XL,WA,WB,WC) DESTROYED
20258: # (RA) DESTROYED
20259: #
20260: ktrex: #prc # entry point (recursive)
20261: tstl r10 # immediate exit if keyword untraced
20262: beqlu ktrx3
20263: tstl kvtra # immediate exit if trace = 0
20264: beqlu ktrx3
20265: decl kvtra # else decrement trace
20266: movl r9,-(sp) # save xr
20267: movl r10,r9 # copy trblk pointer
20268: movl 4*trkvr(r9),r10 # load vrblk pointer (nmbas)
20269: movl $4*vrval,r6 # set name offset
20270: tstl 4*trfnc(r9) # jump if print trace
20271: beqlu ktrx1
20272: jsb trxeq # else execute full trace
20273: jmp ktrx2 # and jump to exit
20274: #
20275: # HERE FOR PRINT TRACE
20276: #
20277: ktrx1: movl r10,-(sp) # stack vrblk ptr for kwnam
20278: movl r6,-(sp) # stack offset for kwnam
20279: jsb prtsn # print statement number
20280: movl $ch$am,r6 # load ampersand
20281: jsb prtch # print ampersand
20282: jsb prtnm # print keyword name
20283: movl $tmbeb,r9 # point to blank-equal-blank
20284: jsb prtst # print blank-equal-blank
20285: jsb kwnam # get keyword pseudo-variable name
20286: movl r9,dnamp # reset ptr to delete kvblk
20287: jsb acess # get keyword value
20288: .long invalid$ # failure is impossible
20289: jsb prtvl # print keyword value
20290: jsb prtnl # terminate print line
20291: #
20292: # HERE TO EXIT AFTER COMPLETING TRACE
20293: #
20294: ktrx2: movl (sp)+,r9 # restore entry xr
20295: #
20296: # MERGE HERE TO EXIT IF NO TRACE REQUIRED
20297: #
20298: ktrx3: rsb # return to ktrex caller
20299: #enp # end procedure ktrex
20300: #page
20301: #
20302: # KWNAM -- GET PSEUDO-VARIABLE NAME FOR KEYWORD
20303: #
20304: # 1(XS) NAME BASE FOR VRBLK
20305: # 0(XS) OFFSET (SHOULD BE *VRVAL)
20306: # JSR KWNAM CALL TO GET PSEUDO-VARIABLE NAME
20307: # (XS) POPPED TWICE
20308: # (XL,WA) RESULTING PSEUDO-VARIABLE NAME
20309: # (XR,WA,WB) DESTROYED
20310: #
20311: .data 1
20312: kwnam_s: .long 0
20313: .text 0
20314: kwnam: movl (sp)+,kwnam_s # entry point
20315: addl2 $4,sp # ignore name offset
20316: movl (sp)+,r9 # load name base
20317: cmpl r9,state # jump if not natural variable name
20318: bgequ kwnm1
20319: tstl 4*vrlen(r9) # error if not system variable
20320: bnequ kwnm1
20321: movl 4*vrsvp(r9),r9 # else point to svblk
20322: movl 4*svbit(r9),r6 # load bit mask
20323: mcoml btknm,r11 # and with keyword bit
20324: bicl2 r11,r6
20325: tstl r6 # error if no keyword association
20326: beqlu kwnm1
20327: movl 4*svlen(r9),r6 # else load name length in characters
20328: movab 3+(4*svchs)(r6),r6 # compute offset to field we want
20329: bicl2 $3,r6
20330: addl2 r6,r9 # point to svknm field
20331: movl (r9),r7 # load svknm value
20332: movl $4*kvsi$,r6 # set size of kvblk
20333: jsb alloc # allocate kvblk
20334: movl $b$kvt,(r9) # store type word
20335: movl r7,4*kvnum(r9) # store keyword number
20336: movl $trbkv,4*kvvar(r9) # set dummy trblk pointer
20337: movl r9,r10 # copy kvblk pointer
20338: movl $4*kvvar,r6 # set proper offset
20339: jmp *kwnam_s # return to kvnam caller
20340: #
20341: # HERE IF NOT KEYWORD NAME
20342: #
20343: kwnm1: jmp er_251 # keyword operand is not name of defined keyword
20344: #enp # end procedure kwnam
20345: #page
20346: #
20347: # LCOMP-- COMPARE TWO STRINGS LEXICALLY
20348: #
20349: # 1(XS) FIRST ARGUMENT
20350: # 0(XS) SECOND ARGUMENT
20351: # JSR LCOMP CALL TO COMPARE ARUMENTS
20352: # PPM LOC TRANSFER LOC FOR ARG1 NOT STRING
20353: # PPM LOC TRANSFER LOC FOR ARG2 NOT STRING
20354: # PPM LOC TRANSFER LOC IF ARG1 LLT ARG2
20355: # PPM LOC TRANSFER LOC IF ARG1 LEQ ARG2
20356: # PPM LOC TRANSFER LOC IF ARG1 LGT ARG2
20357: # (THE NORMAL RETURN IS NEVER TAKEN)
20358: # (XS) POPPED TWICE
20359: # (XR,XL) DESTROYED
20360: # (WA,WB,WC,RA) DESTROYED
20361: #
20362: .data 1
20363: lcomp_s: .long 0
20364: .text 0
20365: lcomp: movl (sp)+,lcomp_s # entry point
20366: jsb gtstg # convert second arg to string
20367: .long lcmp6 # jump if second arg not string
20368: movl r9,r10 # else save pointer
20369: movl r6,r7 # and length
20370: jsb gtstg # convert first argument to string
20371: .long lcmp5 # jump if not string
20372: movl r6,r8 # save arg 1 length
20373: movab cfp$f(r9),r9 # point to chars of arg 1
20374: movab cfp$f(r10),r10 # point to chars of arg 2
20375: cmpl r6,r7 # jump if arg 1 length is smaller
20376: blequ lcmp1
20377: movl r7,r6 # else set arg 2 length as smaller
20378: #
20379: # HERE WITH SMALLER LENGTH IN (WA)
20380: #
20381: lcmp1: jsb sbcmc # compare strings, jump if unequal
20382: .long lcmp4
20383: .long lcmp3
20384: cmpl r7,r8 # if equal, jump if lengths unequal
20385: bnequ lcmp2
20386: addl3 $4*3,lcomp_s,r11 # else identical strings, leq exit
20387: jmp *(r11)+
20388: #page
20389: #
20390: # LCOMP (CONTINUED)
20391: #
20392: # HERE IF INITIAL STRINGS IDENTICAL, BUT LENGTHS UNEQUAL
20393: #
20394: lcmp2: cmpl r8,r7 # jump if arg 1 length gt arg 2 leng
20395: bgequ lcmp4
20396: #
20397: # HERE IF FIRST ARG LLT SECOND ARG
20398: #
20399: lcmp3: addl3 $4*2,lcomp_s,r11 # take llt exit
20400: jmp *(r11)+
20401: #
20402: # HERE IF FIRST ARG LGT SECOND ARG
20403: #
20404: lcmp4: addl3 $4*4,lcomp_s,r11 # take lgt exit
20405: jmp *(r11)+
20406: #
20407: # HERE IF FIRST ARG IS NOT A STRING
20408: #
20409: lcmp5: movl lcomp_s,r11 # take bad first arg exit
20410: jmp *(r11)+
20411: #
20412: # HERE FOR SECOND ARG NOT A STRING
20413: #
20414: lcmp6: addl3 $4*1,lcomp_s,r11 # take bad second arg error exit
20415: jmp *(r11)+
20416: #enp # end procedure lcomp
20417: #page
20418: #
20419: # LISTR -- LIST SOURCE LINE
20420: #
20421: # LISTR IS USED TO LIST A SOURCE LINE DURING THE INITIAL
20422: # COMPILATION. IT IS CALLED FROM SCANE AND SCANL.
20423: #
20424: # JSR LISTR CALL TO LIST LINE
20425: # (XR,XL,WA,WB,WC) DESTROYED
20426: #
20427: # GLOBAL LOCATIONS USED BY LISTR
20428: #
20429: # ERLST IF LISTING ON ACCOUNT OF AN ERROR
20430: #
20431: # LSTLC COUNT LINES ON CURRENT PAGE
20432: #
20433: # LSTNP MAX NUMBER OF LINES/PAGE
20434: #
20435: # LSTPF SET NON-ZERO IF THE CURRENT SOURCE
20436: # LINE HAS BEEN LISTED, ELSE ZERO.
20437: #
20438: # LSTPG COMPILER LISTING PAGE NUMBER
20439: #
20440: # LSTSN SET IF STMNT NUM TO BE LISTED
20441: #
20442: # R$CIM POINTER TO CURRENT INPUT LINE.
20443: #
20444: # R$TTL TITLE FOR SOURCE LISTING
20445: #
20446: # R$STL PTR TO SUB-TITLE STRING
20447: #
20448: # ENTRY POINT
20449: #
20450: listr: #prc # entry point
20451: tstl cnttl # jump if -title or -stitl
20452: beqlu 0f
20453: jmp list5
20454: 0:
20455: tstl lstpf # immediate exit if already listed
20456: beqlu 0f
20457: jmp list4
20458: 0:
20459: cmpl lstlc,lstnp # jump if no room
20460: blssu 0f
20461: jmp list6
20462: 0:
20463: #
20464: # HERE AFTER PRINTING TITLE (IF NEEDED)
20465: #
20466: list0: movl r$cim,r9 # load pointer to current image
20467: movab cfp$f(r9),r9 # point to characters
20468: movzbl (r9),r6 # load first character
20469: movl lstsn,r9 # load statement number
20470: tstl r9 # jump if no statement number
20471: beqlu list2
20472: movl r9,r5 # else get stmnt number as integer
20473: cmpl stage,$stgic # skip if execute time
20474: bnequ list1
20475: cmpl r6,$ch$as # no stmnt number list if comment
20476: beqlu list2
20477: cmpl r6,$ch$mn # no stmnt no. if control card
20478: beqlu list2
20479: #
20480: # PRINT STATEMENT NUMBER
20481: #
20482: list1: jsb prtin # else print statement number
20483: clrl lstsn # and clear for next time in
20484: #page
20485: #
20486: # LISTR (CONTINUED)
20487: #
20488: # MERGE HERE AFTER PRINTING STATEMENT NUMBER (IF REQUIRED)
20489: #
20490: list2: movl $stnpd,profs # point past statement number
20491: movl r$cim,r9 # load pointer to current image
20492: jsb prtst # print it
20493: incl lstlc # bump line counter
20494: tstl erlst # jump if error copy to int.ch.
20495: bnequ list3
20496: jsb prtnl # terminate line
20497: tstl cswdb # jump if -single mode
20498: beqlu list3
20499: jsb prtnl # else add a blank line
20500: incl lstlc # and bump line counter
20501: #
20502: # HERE AFTER PRINTING SOURCE IMAGE
20503: #
20504: list3: movl sp,lstpf # set flag for line printed
20505: #
20506: # MERGE HERE TO EXIT
20507: #
20508: list4: rsb # return to listr caller
20509: #
20510: # PRINT TITLE AFTER -TITLE OR -STITL CARD
20511: #
20512: list5: clrl cnttl # clear flag
20513: #
20514: # EJECT TO NEW PAGE AND LIST TITLE
20515: #
20516: list6: jsb prtps # eject
20517: tstl prich # skip if listing to regular printer
20518: beqlu list7
20519: cmpl r$ttl,$nulls # terminal listing omits null title
20520: bnequ 0f
20521: jmp list0
20522: 0:
20523: #
20524: # LIST TITLE
20525: #
20526: list7: jsb listt # list title
20527: jmp list0 # merge
20528: #enp # end procedure listr
20529: #page
20530: #
20531: # LISTT -- LIST TITLE AND SUBTITLE
20532: #
20533: # USED DURING COMPILATION TO PRINT PAGE HEADING
20534: #
20535: # JSR LISTT CALL TO LIST TITLE
20536: # (XR,WA) DESTROYED
20537: #
20538: listt: #prc # entry point
20539: movl r$ttl,r9 # point to source listing title
20540: jsb prtst # print title
20541: movl lstpo,profs # set offset
20542: movl $lstms,r9 # set page message
20543: jsb prtst # print page message
20544: incl lstpg # bump page number
20545: movl lstpg,r5 # load page number as integer
20546: jsb prtin # print page number
20547: jsb prtnl # terminate title line
20548: addl2 $num02,lstlc # count title line and blank line
20549: #
20550: # PRINT SUB-TITLE (IF ANY)
20551: #
20552: movl r$stl,r9 # load pointer to sub-title
20553: tstl r9 # jump if no sub-title
20554: beqlu lstt1
20555: jsb prtst # else print sub-title
20556: jsb prtnl # terminate line
20557: incl lstlc # bump line count
20558: #
20559: # RETURN POINT
20560: #
20561: lstt1: jsb prtnl # print a blank line
20562: rsb # return to caller
20563: #enp # end procedure listt
20564: #page
20565: #
20566: # NEXTS -- ACQUIRE NEXT SOURCE IMAGE
20567: #
20568: # NEXTS IS USED TO ACQUIRE THE NEXT SOURCE IMAGE AT COMPILE
20569: # TIME. IT ASSUMES THAT A PRIOR CALL TO READR HAS INPUT
20570: # A LINE IMAGE (SEE PROCEDURE READR). BEFORE THE CURRENT
20571: # IMAGE IS FINALLY LOST IT MAY BE LISTED HERE.
20572: #
20573: # JSR NEXTS CALL TO ACQUIRE NEXT INPUT LINE
20574: # (XR,XL,WA,WB,WC) DESTROYED
20575: #
20576: # GLOBAL VALUES AFFECTED
20577: #
20578: # R$CNI ON INPUT, NEXT IMAGE. ON
20579: # EXIT RESET TO ZERO
20580: #
20581: # R$CIM ON EXIT, SET TO POINT TO IMAGE
20582: #
20583: # SCNIL INPUT IMAGE LENGTH ON EXIT
20584: #
20585: # SCNSE RESET TO ZERO ON EXIT
20586: #
20587: # LSTPF SET ON EXIT IF LINE IS LISTED
20588: #
20589: nexts: #prc # entry point
20590: tstl cswls # jump if -nolist
20591: beqlu nxts2
20592: movl r$cim,r9 # point to image
20593: tstl r9 # jump if no image
20594: beqlu nxts2
20595: movab cfp$f(r9),r9 # get char ptr
20596: movzbl (r9),r6 # get first char
20597: cmpl r6,$ch$mn # jump if not ctrl card
20598: bnequ nxts1
20599: tstl cswpr # jump if -noprint
20600: beqlu nxts2
20601: #
20602: # HERE TO CALL LISTER
20603: #
20604: nxts1: jsb listr # list line
20605: #
20606: # HERE AFTER POSSIBLE LISTING
20607: #
20608: nxts2: movl r$cni,r9 # point to next image
20609: movl r9,r$cim # set as next image
20610: clrl r$cni # clear next image pointer
20611: movl 4*sclen(r9),r6 # get input image length
20612: movl cswin,r7 # get max allowable length
20613: cmpl r6,r7 # skip if not too long
20614: blequ nxts3
20615: movl r7,r6 # else truncate
20616: #
20617: # HERE WITH LENGTH IN (WA)
20618: #
20619: nxts3: movl r6,scnil # use as record length
20620: clrl scnse # reset scnse
20621: clrl lstpf # set line not listed yet
20622: rsb # return to nexts caller
20623: #enp # end procedure nexts
20624: #page
20625: #
20626: # PATIN -- PATTERN CONSTRUCTION FOR LEN,POS,RPOS,TAB,RTAB
20627: #
20628: # THESE PATTERN TYPES ALL GENERATE A SIMILAR NODE TYPE. SO
20629: # THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION
20630: # FOR ACTUAL ENTRY POINTS FOR THESE FIVE FUNCTIONS.
20631: #
20632: # (WA) PCODE FOR EXPRESSION ARG CASE
20633: # (WB) PCODE FOR INTEGER ARG CASE
20634: # JSR PATIN CALL TO BUILD PATTERN NODE
20635: # PPM LOC TRANSFER LOC FOR NOT INTEGER OR EXP
20636: # PPM LOC TRANSFER LOC FOR INT OUT OF RANGE
20637: # (XR) POINTER TO CONSTRUCTED NODE
20638: # (XL,WA,WB,WC,IA) DESTROYED
20639: #
20640: .data 1
20641: patin_s: .long 0
20642: .text 0
20643: patin: movl (sp)+,patin_s # entry point
20644: movl r6,r10 # preserve expression arg pcode
20645: jsb gtsmi # try to convert arg as small integer
20646: .long ptin2 # jump if not integer
20647: .long ptin3 # jump if out of range
20648: #
20649: # COMMON SUCCESSFUL EXIT POINT
20650: #
20651: ptin1: jsb pbild # build pattern node
20652: addl3 $4*2,patin_s,r11 # return to caller
20653: jmp (r11)
20654: #
20655: # HERE IF ARGUMENT IS NOT AN INTEGER
20656: #
20657: ptin2: movl r10,r7 # copy expr arg case pcode
20658: cmpl (r9),$b$e$$ # all ok if expression arg
20659: blequ ptin1
20660: movl patin_s,r11 # else take error exit for wrong type
20661: jmp *(r11)+
20662: #
20663: # HERE FOR ERROR OF OUT OF RANGE INTEGER ARGUMENT
20664: #
20665: ptin3: addl3 $4*1,patin_s,r11 # take out-of-range error exit
20666: jmp *(r11)+
20667: #enp # end procedure patin
20668: #page
20669: #
20670: # PATST -- PATTERN CONSTRUCTION FOR ANY,NOTANY,
20671: # BREAK,SPAN AND BREAKX PATTERN FUNCTIONS.
20672: #
20673: # THESE PATTERN FUNCTIONS BUILD SIMILAR TYPES OF NODES AND
20674: # THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION
20675: # FOR ACTUAL ENTRY POINTS FOR THESE FIVE PATTERN FUNCTIONS.
20676: #
20677: # 0(XS) STRING ARGUMENT
20678: # (WB) PCODE FOR ONE CHAR ARGUMENT
20679: # (XL) PCODE FOR MULTI-CHAR ARGUMENT
20680: # (WC) PCODE FOR EXPRESSION ARGUMENT
20681: # JSR PATST CALL TO BUILD NODE
20682: # PPM LOC TRANSFER LOC IF NOT STRING OR EXPR
20683: # (XS) POPPED PAST STRING ARGUMENT
20684: # (XR) POINTER TO CONSTRUCTED NODE
20685: # (XL) DESTROYED
20686: # (WA,WB,WC,RA) DESTROYED
20687: #
20688: # NOTE THAT THERE IS A SPECIAL CALL TO PATST IN THE EVALS
20689: # PROCEDURE WITH A SLIGHTLY DIFFERENT FORM. SEE EVALS
20690: # FOR DETAILS OF THE FORM OF THIS CALL.
20691: #
20692: .data 1
20693: patst_s: .long 0
20694: .text 0
20695: patst: movl (sp)+,patst_s # entry point
20696: jsb gtstg # convert argument as string
20697: .long pats7 # jump if not string
20698: cmpl r6,$num01 # jump if not one char string
20699: bnequ pats2
20700: #
20701: # HERE FOR ONE CHAR STRING CASE
20702: #
20703: tstl r7 # treat as multi-char if evals call
20704: beqlu pats2
20705: movab cfp$f(r9),r9 # point to character
20706: movzbl (r9),r9 # load character
20707: #
20708: # COMMON EXIT POINT AFTER SUCCESSFUL CONSTRUCTION
20709: #
20710: pats1: jsb pbild # call routine to build node
20711: addl3 $4*1,patst_s,r11 # return to patst caller
20712: jmp (r11)
20713: #page
20714: #
20715: # PATST (CONTINUED)
20716: #
20717: # HERE FOR MULTI-CHARACTER STRING CASE
20718: #
20719: pats2: movl r10,-(sp) # save multi-char pcode
20720: movl r9,-(sp) # save string pointer
20721: movl ctmsk,r8 # load current mask bit
20722: ashl $1,r8,r8 # shift to next position
20723: tstl r8 # skip if position left in this tbl
20724: bnequ pats4
20725: #
20726: # HERE WE MUST ALLOCATE A NEW CHARACTER TABLE
20727: #
20728: movl $4*ctsi$,r6 # set size of ctblk
20729: jsb alloc # allocate ctblk
20730: movl r9,r$ctp # store ptr to new ctblk
20731: movl $b$ctt,(r9)+ # store type code, bump ptr
20732: movl $cfp$a,r7 # set number of words to clear
20733: movl bits0,r8 # load all zero bits
20734: #
20735: # LOOP TO CLEAR ALL BITS IN TABLE TO ZEROS
20736: #
20737: pats3: movl r8,(r9)+ # move word of zero bits
20738: sobgtr r7,pats3 # loop till all cleared
20739: movl bits1,r8 # set initial bit position
20740: #
20741: # MERGE HERE WITH BIT POSITION AVAILABLE
20742: #
20743: pats4: movl r8,ctmsk # save parm2 (new bit position)
20744: movl (sp)+,r10 # restore pointer to argument string
20745: movl 4*sclen(r10),r7 # load string length
20746: tstl r7 # jump if null string case
20747: beqlu pats6
20748: # else set loop counter
20749: movab cfp$f(r10),r10 # point to characters in argument
20750: #page
20751: #
20752: # PATST (CONTINUED)
20753: #
20754: # LOOP TO SET BITS IN COLUMN OF TABLE
20755: #
20756: pats5: movzbl (r10)+,r6 # load next character
20757: moval 0[r6],r6 # convert to byte offset
20758: movl r$ctp,r9 # point to ctblk
20759: addl2 r6,r9 # point to ctblk entry
20760: movl r8,r6 # copy bit mask
20761: bisl2 4*ctchs(r9),r6 # or in bits already set
20762: movl r6,4*ctchs(r9) # store resulting bit string
20763: sobgtr r7,pats5 # loop till all bits set
20764: #
20765: # COMPLETE PROCESSING FOR MUTI-CHAR STRING CASE
20766: #
20767: pats6: movl r$ctp,r9 # load ctblk ptr as parm1 for pbild
20768: clrl r10 # clear garbage ptr in xl
20769: movl (sp)+,r7 # load pcode for multi-char str case
20770: jmp pats1 # back to exit (wc=bitstring=parm2)
20771: #
20772: # HERE IF ARGUMENT IS NOT A STRING
20773: #
20774: # NOTE THAT THE CALL FROM EVALS CANNOT PASS AN EXPRESSION
20775: # SINCE EVALP ALWAYS REEVALUATES EXPRESSIONS.
20776: #
20777: pats7: movl r8,r7 # set pcode for expression argument
20778: cmpl (r9),$b$e$$ # jump to exit if expression arg
20779: bgtru 0f
20780: jmp pats1
20781: 0:
20782: movl patst_s,r11 # else take wrong type error exit
20783: jmp *(r11)+
20784: #enp # end procedure patst
20785: #page
20786: #
20787: # PBILD -- BUILD PATTERN NODE
20788: #
20789: # (XR) PARM1 (ONLY IF REQUIRED)
20790: # (WB) PCODE FOR NODE
20791: # (WC) PARM2 (ONLY IF REQUIRED)
20792: # JSR PBILD CALL TO BUILD NODE
20793: # (XR) POINTER TO CONSTRUCTED NODE
20794: # (WA) DESTROYED
20795: #
20796: pbild: #prc # entry point
20797: movl r9,-(sp) # stack possible parm1
20798: movl r7,r9 # copy pcode
20799: movzwl -2(r9),r9 # load entry point id (bl$px)
20800: cmpl r9,$bl$p1 # jump if one parameter
20801: beqlu pbld1
20802: cmpl r9,$bl$p0 # jump if no parameters
20803: beqlu pbld3
20804: #
20805: # HERE FOR TWO PARAMETER CASE
20806: #
20807: movl $4*pcsi$,r6 # set size of p2blk
20808: jsb alloc # allocate block
20809: movl r8,4*parm2(r9) # store second parameter
20810: jmp pbld2 # merge with one parm case
20811: #
20812: # HERE FOR ONE PARAMETER CASE
20813: #
20814: pbld1: movl $4*pbsi$,r6 # set size of p1blk
20815: jsb alloc # allocate node
20816: #
20817: # MERGE HERE FROM TWO PARM CASE
20818: #
20819: pbld2: movl (sp),4*parm1(r9)# store first parameter
20820: jmp pbld4 # merge with no parameter case
20821: #
20822: # HERE FOR CASE OF NO PARAMETERS
20823: #
20824: pbld3: movl $4*pasi$,r6 # set size of p0blk
20825: jsb alloc # allocate node
20826: #
20827: # MERGE HERE FROM OTHER CASES
20828: #
20829: pbld4: movl r7,(r9) # store pcode
20830: addl2 $4,sp # pop first parameter
20831: movl $ndnth,4*pthen(r9) # set nothen successor pointer
20832: rsb # return to pbild caller
20833: #enp # end procedure pbild
20834: #page
20835: #
20836: # PCONC -- CONCATENATE TWO PATTERNS
20837: #
20838: # (XL) PTR TO RIGHT PATTERN
20839: # (XR) PTR TO LEFT PATTERN
20840: # JSR PCONC CALL TO CONCATENATE PATTERNS
20841: # (XR) PTR TO CONCATENATED PATTERN
20842: # (XL,WA,WB,WC) DESTROYED
20843: #
20844: #
20845: # TO CONCATENATE TWO PATTERNS, ALL SUCCESSORS IN THE LEFT
20846: # PATTERN WHICH POINT TO THE NOTHEN NODE MUST BE CHANGED TO
20847: # POINT TO THE RIGHT PATTERN. HOWEVER, THIS MODIFICATION
20848: # MUST BE PERFORMED ON A COPY OF THE LEFT ARGUMENT RATHER
20849: # THAN THE LEFT ARGUMENT ITSELF, SINCE THE LEFT ARGUMENT
20850: # MAY BE POINTED TO BY SOME OTHER VARIABLE VALUE.
20851: #
20852: # ACCORDINGLY, IT IS NECESSARY TO COPY THE LEFT ARGUMENT.
20853: # THIS IS NOT A TRIVIAL PROCESS SINCE WE MUST AVOID COPYING
20854: # NODES MORE THAN ONCE AND THE PATTERN IS A GRAPH STRUCTURE
20855: # THE FOLLOWING ALGORITHM IS EMPLOYED.
20856: #
20857: # THE STACK IS USED TO STORE A LIST OF NODES WHICH
20858: # HAVE ALREADY BEEN COPIED. THE FORMAT OF THE ENTRIES ON
20859: # THIS LIST CONSISTS OF A TWO WORD BLOCK. THE FIRST WORD
20860: # IS THE OLD ADDRESS AND THE SECOND WORD IS THE ADDRESS
20861: # OF THE COPY. THIS LIST IS SEARCHED BY THE PCOPY
20862: # ROUTINE TO AVOID MAKING DUPLICATE COPIES. A TRICK IS
20863: # USED TO ACCOMPLISH THE CONCATENATION AT THE SAME TIME.
20864: # A SPECIAL ENTRY IS MADE TO START WITH ON THE STACK. THIS
20865: # ENTRY RECORDS THAT THE NOTHEN NODE HAS BEEN COPIED
20866: # ALREADY AND THE ADDRESS OF ITS COPY IS THE RIGHT PATTERN.
20867: # THIS AUTOMATICALLY PERFORMS THE CORRECT REPLACEMENTS.
20868: #
20869: pconc: #prc # entry point
20870: clrl -(sp) # make room for one entry at bottom
20871: movl sp,r8 # store pointer to start of list
20872: movl $ndnth,-(sp) # stack nothen node as old node
20873: movl r10,-(sp) # store right arg as copy of nothen
20874: movl sp,r10 # initialize pointer to stack entries
20875: jsb pcopy # copy first node of left arg
20876: movl r6,4*2(r10) # store as result under list
20877: #page
20878: #
20879: # PCONC (CONTINUED)
20880: #
20881: # THE FOLLOWING LOOP SCANS ENTRIES IN THE LIST AND MAKES
20882: # SURE THAT THEIR SUCCESSORS HAVE BEEN COPIED.
20883: #
20884: pcnc1: cmpl r10,sp # jump if all entries processed
20885: beqlu pcnc2
20886: movl -(r10),r9 # else load next old address
20887: movl 4*pthen(r9),r9 # load pointer to successor
20888: jsb pcopy # copy successor node
20889: movl -(r10),r9 # load pointer to new node (copy)
20890: movl r6,4*pthen(r9) # store ptr to new successor
20891: #
20892: # NOW CHECK FOR SPECIAL CASE OF ALTERNATION NODE WHERE
20893: # PARM1 POINTS TO A NODE AND MUST BE COPIED LIKE PTHEN.
20894: #
20895: cmpl (r9),$p$alt # loop back if not
20896: bnequ pcnc1
20897: movl 4*parm1(r9),r9 # else load pointer to alternative
20898: jsb pcopy # copy it
20899: movl (r10),r9 # restore ptr to new node
20900: movl r6,4*parm1(r9) # store ptr to copied alternative
20901: jmp pcnc1 # loop back for next entry
20902: #
20903: # HERE AT END OF COPY PROCESS
20904: #
20905: pcnc2: movl r8,sp # restore stack pointer
20906: movl (sp)+,r9 # load pointer to copy
20907: rsb # return to pconc caller
20908: #enp # end procedure pconc
20909: #page
20910: #
20911: # PCOPY -- COPY A PATTERN NODE
20912: #
20913: # PCOPY IS CALLED FROM THE PCONC PROCEDURE TO COPY A SINGLE
20914: # PATTERN NODE. THE COPY IS ONLY CARRIED OUT IF THE NODE
20915: # HAS NOT BEEN COPIED ALREADY.
20916: #
20917: # (XR) POINTER TO NODE TO BE COPIED
20918: # (XT) PTR TO CURRENT LOC IN COPY LIST
20919: # (WC) POINTER TO LIST OF COPIED NODES
20920: # JSR PCOPY CALL TO COPY A NODE
20921: # (WA) POINTER TO COPY
20922: # (WB,XR) DESTROYED
20923: #
20924: .data 1
20925: pcopy_s: .long 0
20926: .text 0
20927: pcopy: movl (sp)+,pcopy_s # entry point
20928: movl r10,r7 # save xt
20929: movl r8,r10 # point to start of list
20930: #
20931: # LOOP TO SEARCH LIST OF NODES COPIED ALREADY
20932: #
20933: pcop1: subl2 $4,r10 # point to next entry on list
20934: cmpl r9,(r10) # jump if match
20935: beqlu pcop2
20936: subl2 $4,r10 # else skip over copied address
20937: cmpl r10,sp # loop back if more to test
20938: bnequ pcop1
20939: #
20940: # HERE IF NOT IN LIST, PERFORM COPY
20941: #
20942: movl (r9),r6 # load first word of block
20943: jsb blkln # get length of block
20944: movl r9,r10 # save pointer to old node
20945: jsb alloc # allocate space for copy
20946: movl r10,-(sp) # store old address on list
20947: movl r9,-(sp) # store new address on list
20948: jsb sbchk # check for stack overflow
20949: jsb sbmvw # move words from old block to copy
20950: movl (sp),r6 # load pointer to copy
20951: jmp pcop3 # jump to exit
20952: #
20953: # HERE IF WE FIND ENTRY IN LIST
20954: #
20955: pcop2: movl -(r10),r6 # load address of copy from list
20956: #
20957: # COMMON EXIT POINT
20958: #
20959: pcop3: movl r7,r10 # restore xt
20960: jmp *pcopy_s # return to pcopy caller
20961: #enp # end procedure pcopy
20962: #page
20963: #
20964: # PRFLR -- PRINT PROFILE
20965: # PRFLR IS CALLED TO PRINT THE CONTENTS OF THE PROFILE
20966: # TABLE IN A FAIRLY READABLE TABULAR FORMAT.
20967: #
20968: # JSR PRFLR CALL TO PRINT PROFILE
20969: # (WA,IA) DESTROYED
20970: #
20971: prflr: #prc
20972: tstl pfdmp # no printing if no profiling done
20973: bnequ 0f
20974: jmp prfl4
20975: 0:
20976: movl r9,-(sp) # preserve entry xr
20977: movl r7,pfsvw # and also wb
20978: jsb prtpg # eject
20979: movl $pfms1,r9 # load msg /program profile/
20980: jsb prtst # and print it
20981: jsb prtnl # followed by newline
20982: jsb prtnl # and another
20983: movl $pfms2,r9 # point to first hdr
20984: jsb prtst # print it
20985: jsb prtnl # new line
20986: movl $pfms3,r9 # second hdr
20987: jsb prtst # print it
20988: jsb prtnl # new line
20989: jsb prtnl # and another blank line
20990: clrl r7 # initial stmt count
20991: movl pftbl,r9 # point to table origin
20992: addl2 $4*num02,r9 # bias past xnblk header (sgd07)
20993: #
20994: # LOOP HERE TO PRINT SUCCESSIVE ENTRIES
20995: #
20996: prfl1: incl r7 # bump stmt nr
20997: movl (r9),r5 # load nr of executions
20998: tstl r5 # no printing if zero
20999: beql prfl3
21000: movl $pfpd1,profs # point where to print
21001: jsb prtin # and print it
21002: clrl profs # back to start of line
21003: movl r7,r5 # load stmt nr
21004: jsb prtin # print it there
21005: movl $pfpd2,profs # and pad past count
21006: movl 4*cfp$i(r9),r5 # load total exec time
21007: jsb prtin # print that too
21008: movl 4*cfp$i(r9),r5 # reload time
21009: mull2 intth,r5 # convert to microsec
21010: bvs prfl2
21011: divl2 (r9),r5 # divide by executions
21012: movl $pfpd3,profs # pad last print
21013: jsb prtin # and print mcsec/execn
21014: #
21015: # MERGE AFTER PRINTING TIME
21016: #
21017: prfl2: jsb prtnl # thats another line
21018: #
21019: # HERE TO GO TO NEXT ENTRY
21020: #
21021: prfl3: addl2 $4*pf$i2,r9 # bump index ptr (sgd07)
21022: cmpl r7,pfnte # loop if more stmts
21023: blssu prfl1
21024: movl (sp)+,r9 # restore callers xr
21025: movl pfsvw,r7 # and wb too
21026: #
21027: # HERE TO EXIT
21028: #
21029: prfl4: rsb # return
21030: #enp # end of prflr
21031: #page
21032: #
21033: # PRFLU -- UPDATE AN ENTRY IN THE PROFILE TABLE
21034: #
21035: # ON ENTRY, KVSTN CONTAINS NR OF STMT TO PROFILE
21036: #
21037: # JSR PRFLU CALL TO UPDATE ENTRY
21038: # (IA) DESTROYED
21039: #
21040: prflu: #prc
21041: tstl pffnc # skip if just entered function
21042: beqlu 0f
21043: jmp pflu4
21044: 0:
21045: movl r9,-(sp) # preserve entry xr
21046: movl r6,pfsvw # save wa (sgd07)
21047: tstl pftbl # branch if table allocated
21048: bnequ pflu2
21049: #
21050: # HERE IF SPACE FOR PROFILE TABLE NOT YET ALLOCATED.
21051: # CALCULATE SIZE NEEDED, ALLOCATE A STATIC XNBLK, AND
21052: # INITIALIZE IT ALL TO ZERO.
21053: # THE TIME TAKEN FOR THIS WILL BE ATTRIBUTED TO THE CURRENT
21054: # STATEMENT (ASSIGNMENT TO KEYWD PROFILE), BUT SINCE THE
21055: # TIMING FOR THIS STATEMENT IS UP THE POLE ANYWAY, THIS
21056: # DOESNT REALLY MATTER...
21057: #
21058: subl2 $num01,pfnte # adjust for extra count (sgd07)
21059: movl pfi2a,r5 # convrt entry size to int
21060: movl r5,pfste # and store safely for later
21061: movl pfnte,r5 # load table length as integer
21062: mull2 pfste,r5 # multiply by entry size
21063: movl r5,r6 # get back address-style
21064: addl2 $num02,r6 # add on 2 word overhead
21065: moval 0[r6],r6 # convert the whole lot to bytes
21066: jsb alost # gimme the space
21067: movl r9,pftbl # save block pointer
21068: movl $b$xnt,(r9)+ # put block type and ...
21069: movl r6,(r9)+ # ... length into header
21070: movl r5,r6 # get back nr of wds in data area
21071: # load the counter
21072: #
21073: # LOOP HERE TO ZERO THE BLOCK DATA
21074: #
21075: pflu1: clrl (r9)+ # blank a word
21076: sobgtr r6,pflu1 # and alllllll the rest
21077: #
21078: # END OF ALLOCATION. MERGE BACK INTO ROUTINE
21079: #
21080: pflu2: movl kvstn,r5 # load nr of stmt just ended
21081: subl2 intv1,r5 # make into index offset
21082: mull2 pfste,r5 # make offset of table entry
21083: movl r5,r6 # convert to address
21084: moval 0[r6],r6 # get as baus
21085: addl2 $4*num02,r6 # offset includes table header
21086: movl pftbl,r9 # get table start
21087: cmpl r6,4*num01(r9) # if out of table, skip it
21088: bgequ pflu3
21089: addl2 r6,r9 # else point to entry
21090: movl (r9),r5 # get nr of executions so far
21091: addl2 intv1,r5 # nudge up one
21092: movl r5,(r9) # and put back
21093: jsb systm # get time now
21094: movl r5,pfetm # stash ending time
21095: subl2 pfstm,r5 # subtract start time
21096: addl2 4*cfp$i(r9),r5 # add cumulative time so far
21097: movl r5,4*cfp$i(r9) # and put back new total
21098: movl pfetm,r5 # load end time of this stmt ...
21099: movl r5,pfstm # ... which is start time of next
21100: #
21101: # MERGE HERE TO EXIT
21102: #
21103: pflu3: movl (sp)+,r9 # restore callers xr
21104: movl pfsvw,r6 # restore saved reg
21105: rsb # and return
21106: #
21107: # HERE IF PROFILE IS SUPPRESSED BECAUSE A PROGRAM DEFINED
21108: # FUNCTION IS ABOUT TO BE ENTERED, AND SO THE CURRENT STMT
21109: # HAS NOT YET FINISHED
21110: #
21111: pflu4: clrl pffnc # reset the condition flag
21112: rsb # and immediate return
21113: #enp # end of procedure prflu
21114: #page
21115: #
21116: # PRPAR - PROCESS PRINT PARAMETERS
21117: #
21118: # (WC) IF NONZERO ASSOCIATE TERMINAL ONLY
21119: # JSR PRPAR CALL TO PROCESS PRINT PARAMETERS
21120: # (XL,XR,WA,WB,WC) DESTROYED
21121: #
21122: # SINCE MEMORY ALLOCATION IS UNDECIDED ON INITIAL CALL,
21123: # TERMINAL CANNOT BE ASSOCIATED. THE ENTRY WITH WC NON-ZERO
21124: # IS PROVIDED SO A LATER CALL CAN BE MADE TO COMPLETE THIS.
21125: #
21126: prpar: #prc # entry point
21127: tstl r8 # jump to associate terminal
21128: beqlu 0f
21129: jmp prpa7
21130: 0:
21131: jsb syspp # get print parameters
21132: tstl r7 # jump if lines/page specified
21133: bnequ prpa1
21134: movl $cfp$m,r7 # else use a large value
21135: ashl $-1,r7,r7 # but not too large
21136: #
21137: # STORE LINE COUNT/PAGE
21138: #
21139: prpa1: movl r7,lstnp # store number of lines/page
21140: movl r7,lstlc # pretend page is full initially
21141: clrl lstpg # clear page number
21142: movl prlen,r7 # get prior length if any
21143: tstl r7 # skip if no length
21144: beqlu prpa2
21145: cmpl r6,r7 # skip storing if too big
21146: bgtru prpa3
21147: #
21148: # STORE PRINT BUFFER LENGTH
21149: #
21150: prpa2: movl r6,prlen # store value
21151: #
21152: # PROCESS BITS OPTIONS
21153: #
21154: prpa3: movl bits3,r7 # bit 3 mask
21155: mcoml r8,r11 # get -nolist bit
21156: bicl2 r11,r7
21157: tstl r7 # skip if clear
21158: beqlu prpa4
21159: clrl cswls # set -nolist
21160: #
21161: # CHECK IF FAIL REPORTS GOTO INTERACTIVE CHANNEL
21162: #
21163: prpa4: movl bits1,r7 # bit 1 mask
21164: mcoml r8,r11 # get bit
21165: bicl2 r11,r7
21166: movl r7,erich # store int. chan. error flag
21167: movl bits2,r7 # bit 2 mask
21168: mcoml r8,r11 # get bit
21169: bicl2 r11,r7
21170: movl r7,prich # flag for std printer on int. chan.
21171: movl bits4,r7 # bit 4 mask
21172: mcoml r8,r11 # get bit
21173: bicl2 r11,r7
21174: movl r7,cpsts # flag for compile stats suppressn.
21175: movl bits5,r7 # bit 5 mask
21176: mcoml r8,r11 # get bit
21177: bicl2 r11,r7
21178: movl r7,exsts # flag for exec stats suppression
21179: #page
21180: #
21181: # PRPAR (CONTINUED)
21182: #
21183: movl bits6,r7 # bit 6 mask
21184: mcoml r8,r11 # get bit
21185: bicl2 r11,r7
21186: movl r7,precl # extended/compact listing flag
21187: subl2 $num08,r6 # point 8 chars from line end
21188: tstl r7 # jump if not extended
21189: beqlu prpa5
21190: movl r6,lstpo # store for listing page headings
21191: #
21192: # CONTINUE OPTION PROCESSING
21193: #
21194: prpa5: movl bits7,r7 # bit 7 mask
21195: mcoml r8,r11 # get bit 7
21196: bicl2 r11,r7
21197: movl r7,cswex # set -noexecute if non-zero
21198: movl bit10,r7 # bit 10 mask
21199: mcoml r8,r11 # get bit 10
21200: bicl2 r11,r7
21201: movl r7,headp # pretend printed to omit headers
21202: movl bits9,r7 # bit 9 mask
21203: mcoml r8,r11 # get bit 9
21204: bicl2 r11,r7
21205: movl r7,prsto # keep it as std listing option
21206: tstl r7 # skip if clear
21207: beqlu prpa6
21208: movl prlen,r6 # get print buffer length
21209: subl2 $num08,r6 # point 8 chars from line end
21210: movl r6,lstpo # store page offset
21211: #
21212: # CHECK FOR TERMINAL
21213: #
21214: prpa6: mcoml bits8,r11 # see if terminal to be activated
21215: bicl2 r11,r8
21216: tstl r8 # jump if terminal required
21217: beqlu 0f
21218: jmp prpa7
21219: 0:
21220: tstl initr # jump if no terminal to detach
21221: beqlu prpa8
21222: movl $v$ter,r10 # ptr to /terminal/
21223: jsb gtnvr # get vrblk pointer
21224: .long invalid$ # cant fail
21225: movl $nulls,4*vrval(r9) # clear value of terminal
21226: jsb setvr # remove association
21227: jmp prpa8 # return
21228: #
21229: # ASSOCIATE TERMINAL
21230: #
21231: prpa7: movl sp,initr # note terminal associated
21232: tstl dnamb # cant if memory not organised
21233: beqlu prpa8
21234: movl $v$ter,r10 # point to terminal string
21235: movl $trtou,r7 # output trace type
21236: jsb inout # attach output trblk to vrblk
21237: movl r9,-(sp) # stack trblk ptr
21238: movl $v$ter,r10 # point to terminal string
21239: movl $trtin,r7 # input trace type
21240: jsb inout # attach input trace blk
21241: movl (sp)+,4*vrval(r9)# add output trblk to chain
21242: #
21243: # RETURN POINT
21244: #
21245: prpa8: rsb # return
21246: #enp # end procedure prpar
21247: #page
21248: #
21249: # PRTCH -- PRINT A CHARACTER
21250: #
21251: # PRTCH IS USED TO PRINT A SINGLE CHARACTER
21252: #
21253: # (WA) CHARACTER TO BE PRINTED
21254: # JSR PRTCH CALL TO PRINT CHARACTER
21255: #
21256: prtch: #prc # entry point
21257: movl r9,-(sp) # save xr
21258: cmpl profs,prlen # jump if room in buffer
21259: bnequ prch1
21260: jsb prtnl # else print this line
21261: #
21262: # HERE AFTER MAKING SURE WE HAVE ROOM
21263: #
21264: prch1: movl prbuf,r9 # point to print buffer
21265: movl profs,r11 # [get in scratch register]
21266: movab cfp$f(r9)[r11],r9# point to next character location
21267: movb r6,(r9) # store new character
21268: #csc r9 # complete store characters
21269: incl profs # bump pointer
21270: movl (sp)+,r9 # restore entry xr
21271: rsb # return to prtch caller
21272: #enp # end procedure prtch
21273: #page
21274: #
21275: # PRTIC -- PRINT TO INTERACTIVE CHANNEL
21276: #
21277: # PRTIC IS CALLED TO PRINT THE CONTENTS OF THE STANDARD
21278: # PRINT BUFFER TO THE INTERACTIVE CHANNEL. IT IS ONLY
21279: # CALLED AFTER PRTST HAS SET UP THE STRING FOR PRINTING.
21280: # IT DOES NOT CLEAR THE BUFFER.
21281: #
21282: # JSR PRTIC CALL FOR PRINT
21283: # (WA,WB) DESTROYED
21284: #
21285: prtic: #prc # entry point
21286: movl r9,-(sp) # save xr
21287: movl prbuf,r9 # point to buffer
21288: movl profs,r6 # no of chars
21289: jsb syspi # print
21290: .long prtc2 # fail return
21291: #
21292: # RETURN
21293: #
21294: prtc1: movl (sp)+,r9 # restore xr
21295: rsb # return
21296: #
21297: # ERROR OCCURED
21298: #
21299: prtc2: clrl erich # prevent looping
21300: jmp er_252 # error on printing to interactive channel
21301: jmp prtc1 # return
21302: #enp # procedure prtic
21303: #page
21304: #
21305: # PRTIS -- PRINT TO INTERACTIVE AND STANDARD PRINTER
21306: #
21307: # PRTIS PUTS A LINE FROM THE PRINT BUFFER ONTO THE
21308: # INTERACTIVE CHANNEL (IF ANY) AND THE STANDARD PRINTER.
21309: # IT ALWAYS PRINTS TO THE STANDARD PRINTER BUT DOES
21310: # NOT DUPLICATE LINES IF THE STANDARD PRINTER IS
21311: # INTERACTIVE. IT CLEARS DOWN THE PRINT BUFFER.
21312: #
21313: # JSR PRTIS CALL FOR PRINTING
21314: # (WA,WB) DESTROYED
21315: #
21316: prtis: #prc # entry point
21317: tstl prich # jump if standard printer is int.ch.
21318: bnequ prts1
21319: tstl erich # skip if not doing int. error reps.
21320: beqlu prts1
21321: jsb prtic # print to interactive channel
21322: #
21323: # MERGE AND EXIT
21324: #
21325: prts1: jsb prtnl # print to standard printer
21326: rsb # return
21327: #enp # end procedure prtis
21328: #page
21329: #
21330: # PRTIN -- PRINT AN INTEGER
21331: #
21332: # PRTIN PRINTS THE INTEGER VALUE WHICH IS IN THE INTEGER
21333: # ACCUMULATOR. BLOCKS BUILT IN DYNAMIC STORAGE
21334: # DURING THIS PROCESS ARE IMMEDIATELY DELETED.
21335: #
21336: # (IA) INTEGER VALUE TO BE PRINTED
21337: # JSR PRTIN CALL TO PRINT INTEGER
21338: # (IA,RA) DESTROYED
21339: #
21340: prtin: #prc # entry point
21341: movl r9,-(sp) # save xr
21342: jsb icbld # build integer block
21343: cmpl r9,dnamb # jump if icblk below dynamic
21344: blequ prti1
21345: cmpl r9,dnamp # jump if above dynamic
21346: bgequ prti1
21347: movl r9,dnamp # immediately delete it
21348: #
21349: # DELETE ICBLK FROM DYNAMIC STORE
21350: #
21351: prti1: movl r9,-(sp) # stack ptr for gtstg
21352: jsb gtstg # convert to string
21353: .long invalid$ # convert error is impossible
21354: movl r9,dnamp # reset pointer to delete scblk
21355: jsb prtst # print integer string
21356: movl (sp)+,r9 # restore entry xr
21357: rsb # return to prtin caller
21358: #enp # end procedure prtin
21359: #page
21360: #
21361: # PRTMI -- PRINT MESSAGE AND INTEGER
21362: #
21363: # PRTMI IS USED TO PRINT MESSAGES TOGETHER WITH AN INTEGER
21364: # VALUE STARTING IN COLUMN 15 (USED BY THE ROUTINES AT
21365: # THE END OF COMPILATION).
21366: #
21367: # JSR PRTMI CALL TO PRINT MESSAGE AND INTEGER
21368: #
21369: prtmi: #prc # entry point
21370: jsb prtst # print string message
21371: movl $prtmf,profs # set offset to col 15
21372: jsb prtin # print integer
21373: jsb prtnl # print line
21374: rsb # return to prtmi caller
21375: #enp # end procedure prtmi
21376: #page
21377: #
21378: # PRTMX -- AS PRTMI WITH EXTRA COPY TO INTERACTIVE CHAN.
21379: #
21380: # JSR PRTMX CALL FOR PRINTING
21381: # (WA,WB) DESTROYED
21382: #
21383: prtmx: #prc # entry point
21384: jsb prtst # print string message
21385: movl $prtmf,profs # set ptr to column 15
21386: jsb prtin # print integer
21387: jsb prtis # print line
21388: rsb # return
21389: #enp # end procedure prtmx
21390: #page
21391: #
21392: # PRTNL -- PRINT NEW LINE (END PRINT LINE)
21393: #
21394: # PRTNL PRINTS THE CONTENTS OF THE PRINT BUFFER, RESETS
21395: # THE BUFFER TO ALL BLANKS AND RESETS THE PRINT POINTER.
21396: #
21397: # JSR PRTNL CALL TO PRINT LINE
21398: #
21399: prtnl: #prc # entry point
21400: tstl headp # were headers printed
21401: bnequ prnl0
21402: jsb prtps # no - print them
21403: #
21404: # CALL SYSPR
21405: #
21406: prnl0: movl r9,-(sp) # save entry xr
21407: movl r6,prtsa # save wa
21408: movl r7,prtsb # save wb
21409: movl prbuf,r9 # load pointer to buffer
21410: movl profs,r6 # load number of chars in buffer
21411: jsb syspr # call system print routine
21412: .long prnl2 # jump if failed
21413: movl prlnw,r6 # load length of buffer in words
21414: addl2 $4*schar,r9 # point to chars of buffer
21415: movl nullw,r7 # get word of blanks
21416: #
21417: # LOOP TO BLANK BUFFER
21418: #
21419: prnl1: movl r7,(r9)+ # store word of blanks, bump ptr
21420: sobgtr r6,prnl1 # loop till all blanked
21421: #
21422: # EXIT POINT
21423: #
21424: movl prtsb,r7 # restore wb
21425: movl prtsa,r6 # restore wa
21426: movl (sp)+,r9 # restore entry xr
21427: clrl profs # reset print buffer pointer
21428: rsb # return to prtnl caller
21429: #
21430: # FILE FULL OR NO OUTPUT FILE FOR LOAD MODULE
21431: #
21432: prnl2: tstl prtef # jump if not first time
21433: bnequ prnl3
21434: movl sp,prtef # mark first occurrence
21435: jmp er_253 # print limit exceeded on standard output channel
21436: #
21437: # STOP AT ONCE
21438: #
21439: prnl3: movl $nini8,r7 # ending code
21440: movl kvstn,r6 # statement number
21441: jsb sysej # stop
21442: #enp # end procedure prtnl
21443: #page
21444: #
21445: # PRTNM -- PRINT VARIABLE NAME
21446: #
21447: # PRTNM IS USED TO PRINT A CHARACTER REPRESENTATION OF THE
21448: # NAME OF A VARIABLE (NOT A VALUE OF DATATYPE NAME)
21449: # NAMES OF PSEUDO-VARIABLES MAY NOT BE PASSED TO PRTNM.
21450: #
21451: # (XL) NAME BASE
21452: # (WA) NAME OFFSET
21453: # JSR PRTNM CALL TO PRINT NAME
21454: # (WB,WC,RA) DESTROYED
21455: #
21456: prtnm: #prc # entry point (recursive, see prtvl)
21457: movl r6,-(sp) # save wa (offset is collectable)
21458: movl r9,-(sp) # save entry xr
21459: movl r10,-(sp) # save name base
21460: cmpl r10,state # jump if not natural variable
21461: bgequ prn02
21462: #
21463: # HERE FOR NATURAL VARIABLE NAME, RECOGNIZED BY THE FACT
21464: # THAT THE NAME BASE POINTS INTO THE STATIC AREA.
21465: #
21466: movl r10,r9 # point to vrblk
21467: jsb prtvn # print name of variable
21468: #
21469: # COMMON EXIT POINT
21470: #
21471: prn01: movl (sp)+,r10 # restore name base
21472: movl (sp)+,r9 # restore entry value of xr
21473: movl (sp)+,r6 # restore wa
21474: rsb # return to prtnm caller
21475: #
21476: # HERE FOR CASE OF NON-NATURAL VARIABLE
21477: #
21478: prn02: movl r6,r7 # copy name offset
21479: cmpl (r10),$b$pdt # jump if array or table
21480: bnequ prn03
21481: #
21482: # FOR PROGRAM DEFINED DATATYPE, PRT FLD NAME, LEFT PAREN
21483: #
21484: movl 4*pddfp(r10),r9 # load pointer to dfblk
21485: addl2 r6,r9 # add name offset
21486: movl 4*pdfof(r9),r9 # load vrblk pointer for field
21487: jsb prtvn # print field name
21488: movl $ch$pp,r6 # load left paren
21489: jsb prtch # print character
21490: #page
21491: #
21492: # PRTNM (CONTINUED)
21493: #
21494: # NOW WE PRINT AN IDENTIFYING NAME FOR THE OBJECT IF ONE
21495: # CAN BE FOUND. THE FOLLOWING CODE SEARCHES FOR A NATURAL
21496: # VARIABLE WHICH CONTAINS THIS OBJECT AS VALUE. IF SUCH A
21497: # VARIABLE IS FOUND, ITS NAME IS PRINTED, ELSE THE VALUE
21498: # OF THE OBJECT (AS PRINTED BY PRTVL) IS USED INSTEAD.
21499: #
21500: # FIRST WE POINT TO THE PARENT TBBLK IF THIS IS THE CASE OF
21501: # A TABLE ELEMENT. TO DO THIS, CHASE DOWN THE TRNXT CHAIN.
21502: #
21503: prn03: cmpl (r10),$b$tet # jump if we got there (or not te)
21504: bnequ prn04
21505: movl 4*tenxt(r10),r10# else move out on chain
21506: jmp prn03 # and loop back
21507: #
21508: # NOW WE ARE READY FOR THE SEARCH. TO SPEED THINGS UP IN
21509: # THE CASE OF CALLS FROM DUMP WHERE THE SAME NAME BASE
21510: # WILL OCCUR REPEATEDLY WHILE DUMPING AN ARRAY OR TABLE,
21511: # WE REMEMBER THE LAST VRBLK POINTER FOUND IN PRNMV. SO
21512: # FIRST CHECK TO SEE IF WE HAVE THIS ONE AGAIN.
21513: #
21514: prn04: movl prnmv,r9 # point to vrblk we found last time
21515: movl hshtb,r6 # point to hash table in case not
21516: jmp prn07 # jump into search for special check
21517: #
21518: # LOOP THROUGH HASH SLOTS
21519: #
21520: prn05: movl r6,r9 # copy slot pointer
21521: addl2 $4,r6 # bump slot pointer
21522: subl2 $4*vrnxt,r9 # introduce standard vrblk offset
21523: #
21524: # LOOP THROUGH VRBLKS ON ONE HASH CHAIN
21525: #
21526: prn06: movl 4*vrnxt(r9),r9 # point to next vrblk on hash chain
21527: #
21528: # MERGE HERE FIRST TIME TO CHECK BLOCK WE FOUND LAST TIME
21529: #
21530: prn07: movl r9,r8 # copy vrblk pointer
21531: tstl r8 # jump if chain end (or prnmv zero)
21532: beqlu prn09
21533: #page
21534: #
21535: # PRTNM (CONTINUED)
21536: #
21537: # LOOP TO FIND VALUE (CHASE DOWN POSSIBLE TRBLK CHAIN)
21538: #
21539: prn08: movl 4*vrval(r9),r9 # load value
21540: cmpl (r9),$b$trt # loop if that was a trblk
21541: beqlu prn08
21542: #
21543: # NOW WE HAVE THE VALUE, IS THIS THE BLOCK WE WANT
21544: #
21545: cmpl r9,r10 # jump if this matches the name base
21546: beqlu prn10
21547: movl r8,r9 # else point back to that vrblk
21548: jmp prn06 # and loop back
21549: #
21550: # HERE TO MOVE TO NEXT HASH SLOT
21551: #
21552: prn09: cmpl r6,hshte # loop back if more to go
21553: blssu prn05
21554: movl r10,r9 # else not found, copy value pointer
21555: jsb prtvl # print value
21556: jmp prn11 # and merge ahead
21557: #
21558: # HERE WHEN WE FIND A MATCHING ENTRY
21559: #
21560: prn10: movl r8,r9 # copy vrblk pointer
21561: movl r9,prnmv # save for next time in
21562: jsb prtvn # print variable name
21563: #
21564: # MERGE HERE IF NO ENTRY FOUND
21565: #
21566: prn11: movl (r10),r8 # load first word of name base
21567: cmpl r8,$b$pdt # jump if not program defined
21568: bnequ prn13
21569: #
21570: # FOR PROGRAM DEFINED DATATYPE, ADD RIGHT PAREN AND EXIT
21571: #
21572: movl $ch$rp,r6 # load right paren, merge
21573: #
21574: # MERGE HERE TO PRINT FINAL RIGHT PAREN OR BRACKET
21575: #
21576: prn12: jsb prtch # print final character
21577: movl r7,r6 # restore name offset
21578: jmp prn01 # merge back to exit
21579: #page
21580: #
21581: # PRTNM (CONTINUED)
21582: #
21583: # HERE FOR ARRAY OR TABLE
21584: #
21585: prn13: movl $ch$bb,r6 # load left bracket
21586: jsb prtch # and print it
21587: movl (sp),r10 # restore block pointer
21588: movl (r10),r8 # load type word again
21589: cmpl r8,$b$tet # jump if not table
21590: bnequ prn15
21591: #
21592: # HERE FOR TABLE, PRINT SUBSCRIPT VALUE
21593: #
21594: movl 4*tesub(r10),r9 # load subscript value
21595: movl r7,r10 # save name offset
21596: jsb prtvl # print subscript value
21597: movl r10,r7 # restore name offset
21598: #
21599: # MERGE HERE FROM ARRAY CASE TO PRINT RIGHT BRACKET
21600: #
21601: prn14: movl $ch$rb,r6 # load right bracket
21602: jmp prn12 # merge back to print it
21603: #
21604: # HERE FOR ARRAY OR VECTOR, TO PRINT SUBSCRIPT(S)
21605: #
21606: prn15: movl r7,r6 # copy name offset
21607: ashl $-2,r6,r6 # convert to words
21608: cmpl r8,$b$art # jump if arblk
21609: beqlu prn16
21610: #
21611: # HERE FOR VECTOR
21612: #
21613: subl2 $vcvlb,r6 # adjust for standard fields
21614: movl r6,r5 # move to integer accum
21615: jsb prtin # print linear subscript
21616: jmp prn14 # merge back for right bracket
21617: #page
21618: #
21619: # PRTNM (CONTINUED)
21620: #
21621: # HERE FOR ARRAY. FIRST CALCULATE ABSOLUTE SUBSCRIPT
21622: # OFFSETS BY SUCCESSIVE DIVISIONS BY THE DIMENSION VALUES.
21623: # THIS MUST BE DONE RIGHT TO LEFT SINCE THE ELEMENTS ARE
21624: # STORED ROW-WISE. THE SUBSCRIPTS ARE STACKED AS INTEGERS.
21625: #
21626: prn16: movl 4*arofs(r10),r8 # load length of bounds info
21627: addl2 $4,r8 # adjust for arpro field
21628: ashl $-2,r8,r8 # convert to words
21629: subl2 r8,r6 # get linear zero-origin subscript
21630: movl r6,r5 # get integer value
21631: movl 4*arndm(r10),r6 # set num of dimensions as loop count
21632: addl2 4*arofs(r10),r10# point past bounds information
21633: subl2 $4*arlbd,r10 # set ok offset for proper ptr later
21634: #
21635: # LOOP TO STACK SUBSCRIPT OFFSETS
21636: #
21637: prn17: subl2 $4*ardms,r10 # point to next set of bounds
21638: movl r5,prnsi # save current offset
21639: ashq $-32,r4,r4 # get remainder on dividing by dimens
21640: ediv 4*ardim(r10),r4,r11,r5
21641: movl r5,-(sp) # store on stack (one word)
21642: movl prnsi,r5 # reload argument
21643: divl2 4*ardim(r10),r5 # divide to get quotient
21644: sobgtr r6,prn17 # loop till all stacked
21645: clrl r9 # set offset to first set of bounds
21646: movl 4*arndm(r10),r7 # load count of dims to control loop
21647: jmp prn19 # jump into print loop
21648: #
21649: # LOOP TO PRINT SUBSCRIPTS FROM STACK ADJUSTING BY ADDING
21650: # THE APPROPRIATE LOW BOUND VALUE FROM THE ARBLK
21651: #
21652: prn18: movl $ch$cm,r6 # load a comma
21653: jsb prtch # print it
21654: #
21655: # MERGE HERE FIRST TIME IN (NO COMMA REQUIRED)
21656: #
21657: prn19: movl (sp)+,r5 # load subscript offset as integer
21658: addl2 r9,r10 # point to current lbd
21659: addl2 4*arlbd(r10),r5 # add lbd to get signed subscript
21660: subl2 r9,r10 # point back to start of arblk
21661: jsb prtin # print subscript
21662: addl2 $4*ardms,r9 # bump offset to next bounds
21663: sobgtr r7,prn18 # loop back till all printed
21664: jmp prn14 # merge back to print right bracket
21665: #enp # end procedure prtnm
21666: #page
21667: #
21668: # PRTNV -- PRINT NAME VALUE
21669: #
21670: # PRTNV IS USED BY THE TRACE AND DUMP ROUTINES TO PRINT
21671: # A LINE OF THE FORM
21672: #
21673: # NAME = VALUE
21674: #
21675: # NOTE THAT THE NAME INVOLVED CAN NEVER BE A PSEUDO-VAR
21676: #
21677: # (XL) NAME BASE
21678: # (WA) NAME OFFSET
21679: # JSR PRTNV CALL TO PRINT NAME = VALUE
21680: # (WB,WC,RA) DESTROYED
21681: #
21682: prtnv: #prc # entry point
21683: jsb prtnm # print argument name
21684: movl r9,-(sp) # save entry xr
21685: movl r6,-(sp) # save name offset (collectable)
21686: movl $tmbeb,r9 # point to blank equal blank
21687: jsb prtst # print it
21688: movl r10,r9 # copy name base
21689: addl2 r6,r9 # point to value
21690: movl (r9),r9 # load value pointer
21691: jsb prtvl # print value
21692: jsb prtnl # terminate line
21693: movl (sp)+,r6 # restore name offset
21694: movl (sp)+,r9 # restore entry xr
21695: rsb # return to caller
21696: #enp # end procedure prtnv
21697: #page
21698: #
21699: # PRTPG -- PRINT A PAGE THROW
21700: #
21701: # PRINTS A PAGE THROW OR A FEW BLANK LINES ON THE STANDARD
21702: # LISTING CHANNEL DEPENDING ON THE LISTING OPTIONS CHOSEN.
21703: #
21704: # JSR PRTPG CALL FOR PAGE EJECT
21705: #
21706: prtpg: #prc # entry point
21707: cmpl stage,$stgxt # jump if execution time
21708: beqlu prp01
21709: tstl lstlc # return if top of page already
21710: bnequ 0f
21711: jmp prp06
21712: 0:
21713: clrl lstlc # clear line count
21714: #
21715: # CHECK TYPE OF LISTING
21716: #
21717: prp01: movl r9,-(sp) # preserve xr
21718: tstl prstd # eject if flag set
21719: bnequ prp02
21720: tstl prich # jump if interactive listing channel
21721: bnequ prp03
21722: tstl precl # jump if compact listing
21723: beqlu prp03
21724: #
21725: # PERFORM AN EJECT
21726: #
21727: prp02: jsb sysep # eject
21728: jmp prp04 # merge
21729: #
21730: # COMPACT OR INTERACTIVE CHANNEL LISTING. CANT PRINT
21731: # BLANKS UNTIL CHECK MADE FOR HEADERS PRINTED AND FLAG SET.
21732: #
21733: #
21734: prp03: movl headp,r9 # remember headp
21735: movl sp,headp # set to avoid repeated prtpg calls
21736: jsb prtnl # print blank line
21737: jsb prtnl # print blank line
21738: jsb prtnl # print blank line
21739: movl $num03,lstlc # count blank lines
21740: movl r9,headp # restore header flag
21741: #page
21742: #
21743: # PRPTG (CONTINUED)
21744: #
21745: # PRINT THE HEADING
21746: #
21747: prp04: tstl headp # jump if header listed
21748: bnequ prp05
21749: movl sp,headp # mark headers printed
21750: movl r10,-(sp) # keep xl
21751: movl $headr,r9 # point to listing header
21752: jsb prtst # place it
21753: jsb sysid # get system identification
21754: jsb prtst # append extra chars
21755: jsb prtnl # print it
21756: movl r10,r9 # extra header line
21757: jsb prtst # place it
21758: jsb prtnl # print it
21759: jsb prtnl # print a blank
21760: jsb prtnl # and another
21761: addl2 $num04,lstlc # four header lines printed
21762: movl (sp)+,r10 # restore xl
21763: #
21764: # MERGE IF HEADER NOT PRINTED
21765: #
21766: prp05: movl (sp)+,r9 # restore xr
21767: #
21768: # RETURN
21769: #
21770: prp06: rsb # return
21771: #enp # end procedure prtpg
21772: #page
21773: #
21774: # PRTPS - PRINT PAGE WITH TEST FOR STANDARD LISTING OPTION
21775: #
21776: # IF THE STANDARD LISTING OPTION IS SELECTED, INSIST THAT
21777: # AN EJECT BE DONE
21778: #
21779: # JSR PRTPS CALL FOR EJECT
21780: #
21781: prtps: #prc # entry point
21782: movl prsto,prstd # copy option flag
21783: jsb prtpg # print page
21784: clrl prstd # clear flag
21785: rsb # return
21786: #enp # end procedure prtps
21787: #page
21788: #
21789: # PRTSN -- PRINT STATEMENT NUMBER
21790: #
21791: # PRTSN IS USED TO INITIATE A PRINT TRACE LINE BY PRINTING
21792: # ASTERISKS AND THE CURRENT STATEMENT NUMBER. THE ACTUAL
21793: # FORMAT OF THE OUTPUT GENERATED IS.
21794: #
21795: # ***NNNNN**** III.....IIII
21796: #
21797: # NNNNN IS THE STATEMENT NUMBER WITH LEADING ZEROS REPLACED
21798: # BY ASTERISKS (E.G. *******9****)
21799: #
21800: # III...III REPRESENTS A VARIABLE LENGTH OUTPUT CONSISTING
21801: # OF A NUMBER OF LETTER I CHARACTERS EQUAL TO FNCLEVEL.
21802: #
21803: # JSR PRTSN CALL TO PRINT STATEMENT NUMBER
21804: # (WC) DESTROYED
21805: #
21806: prtsn: #prc # entry point
21807: movl r9,-(sp) # save entry xr
21808: movl r6,prsna # save entry wa
21809: movl $tmasb,r9 # point to asterisks
21810: jsb prtst # print asterisks
21811: movl $num04,profs # point into middle of asterisks
21812: movl kvstn,r5 # load statement number as integer
21813: jsb prtin # print integer statement number
21814: movl $prsnf,profs # point past asterisks plus blank
21815: movl kvfnc,r9 # get fnclevel
21816: movl $ch$li,r6 # set letter i
21817: #
21818: # LOOP TO GENERATE LETTER I FNCLEVEL TIMES
21819: #
21820: prsn1: tstl r9 # jump if all set
21821: beqlu prsn2
21822: jsb prtch # else print an i
21823: decl r9 # decrement counter
21824: jmp prsn1 # loop back
21825: #
21826: # MERRE WITH ALL LETTER I CHARACTERS GENERATED
21827: #
21828: prsn2: movl $ch$bl,r6 # get blank
21829: jsb prtch # print blank
21830: movl prsna,r6 # restore entry wa
21831: movl (sp)+,r9 # restore entry xr
21832: rsb # return to prtsn caller
21833: #enp # end procedure prtsn
21834: #page
21835: #
21836: # PRTST -- PRINT STRING
21837: #
21838: # PRTST PLACES A STRING OF CHARACTERS IN THE PRINT BUFFER
21839: #
21840: # SEE PRTNL FOR GLOBAL LOCATIONS USED
21841: #
21842: # NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL)
21843: # IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN)
21844: #
21845: # (XR) STRING TO BE PRINTED
21846: # JSR PRTST CALL TO PRINT STRING
21847: # (PROFS) UPDATED PAST CHARS PLACED
21848: #
21849: prtst: #prc # entry point
21850: tstl headp # were headers printed
21851: bnequ prst0
21852: jsb prtps # no - print them
21853: #
21854: # CALL SYSPR
21855: #
21856: prst0: movl r6,prsva # save wa
21857: movl r7,prsvb # save wb
21858: clrl r7 # set chars printed count to zero
21859: #
21860: # LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING
21861: #
21862: prst1: movl 4*sclen(r9),r6 # load string length
21863: subl2 r7,r6 # subtract count of chars already out
21864: tstl r6 # jump to exit if none left
21865: bnequ 0f
21866: jmp prst4
21867: 0:
21868: movl r10,-(sp) # else stack entry xl
21869: movl r9,-(sp) # save argument
21870: movl r9,r10 # copy for eventual move
21871: movl prlen,r9 # load print buffer length
21872: subl2 profs,r9 # get chars left in print buffer
21873: tstl r9 # skip if room left on this line
21874: bnequ prst2
21875: jsb prtnl # else print this line
21876: movl prlen,r9 # and set full width available
21877: #page
21878: #
21879: # PRTST (CONTINUED)
21880: #
21881: # HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER
21882: #
21883: prst2: cmpl r6,r9 # jump if room for rest of string
21884: blequ prst3
21885: movl r9,r6 # else set to fill line
21886: #
21887: # MERGE HERE WITH CHARACTER COUNT IN WA
21888: #
21889: prst3: movl prbuf,r9 # point to print buffer
21890: movab cfp$f(r10)[r7],r10 # point to location in string
21891: movl profs,r11 # [get in scratch register]
21892: movab cfp$f(r9)[r11],r9# point to location in buffer
21893: addl2 r6,r7 # bump string chars count
21894: addl2 r6,profs # bump buffer pointer
21895: movl r7,prsvc # preserve char counter
21896: jsb sbmvc # move characters to buffer
21897: movl prsvc,r7 # recover char counter
21898: movl (sp)+,r9 # restore argument pointer
21899: movl (sp)+,r10 # restore entry xl
21900: jmp prst1 # loop back to test for more
21901: #
21902: # HERE TO EXIT AFTER PRINTING STRING
21903: #
21904: prst4: movl prsvb,r7 # restore entry wb
21905: movl prsva,r6 # restore entry wa
21906: rsb # return to prtst caller
21907: #enp # end procedure prtst
21908: #page
21909: #
21910: # PRTTR -- PRINT TO TERMINAL
21911: #
21912: # CALLED TO PRINT CONTENTS OF STANDARD PRINT BUFFER TO
21913: # ONLINE TERMINAL. CLEARS BUFFER DOWN AND RESETS PROFS.
21914: #
21915: # JSR PRTTR CALL FOR PRINT
21916: # (WA,WB) DESTROYED
21917: #
21918: prttr: #prc # entry point
21919: movl r9,-(sp) # save xr
21920: jsb prtic # print buffer contents
21921: movl prbuf,r9 # point to print bfr to clear it
21922: movl prlnw,r6 # get buffer length
21923: addl2 $4*schar,r9 # point past scblk header
21924: movl nullw,r7 # get blanks
21925: #
21926: # LOOP TO CLEAR BUFFER
21927: #
21928: prtt1: movl r7,(r9)+ # clear a word
21929: sobgtr r6,prtt1 # loop
21930: clrl profs # reset profs
21931: movl (sp)+,r9 # restore xr
21932: rsb # return
21933: #enp # end procedure prttr
21934: #page
21935: #
21936: # PRTVL -- PRINT A VALUE
21937: #
21938: # PRTVL PLACES AN APPROPRIATE CHARACTER REPRESENTATION OF
21939: # A DATA VALUE IN THE PRINT BUFFER FOR DUMP/TRACE USE.
21940: #
21941: # (XR) VALUE TO BE PRINTED
21942: # JSR PRTVL CALL TO PRINT VALUE
21943: # (WA,WB,WC,RA) DESTROYED
21944: #
21945: prtvl: #prc # entry point, recursive
21946: movl r10,-(sp) # save entry xl
21947: movl r9,-(sp) # save argument
21948: jsb sbchk # check for stack overflow
21949: #
21950: # LOOP BACK HERE AFTER FINDING A TRAP BLOCK (TRBLK)
21951: #
21952: prv01: movl 4*idval(r9),prvsi# copy idval (if any)
21953: movl (r9),r10 # load first word of block
21954: movzwl -2(r10),r10 # load entry point id
21955: casel r10,$0,$bl$$t # switch on block type
21956: 5:
21957: .word prv05-5b # arblk
21958: .word prv15-5b # bcblk
21959: .word prv02-5b
21960: .word prv02-5b
21961: .word prv08-5b # icblk
21962: .word prv09-5b # nmblk
21963: .word prv02-5b
21964: .word prv02-5b
21965: .word prv02-5b
21966: .word prv08-5b # rcblk
21967: .word prv11-5b # scblk
21968: .word prv12-5b # seblk
21969: .word prv13-5b # tbblk
21970: .word prv13-5b # vcblk
21971: .word prv02-5b
21972: .word prv02-5b
21973: .word prv10-5b # pdblk
21974: .word prv04-5b # trblk
21975: #esw # end of switch on block type
21976: #
21977: # HERE FOR BLOCKS FOR WHICH WE JUST PRINT DATATYPE NAME
21978: #
21979: prv02: jsb dtype # get datatype name
21980: jsb prtst # print datatype name
21981: #
21982: # COMMON EXIT POINT
21983: #
21984: prv03: movl (sp)+,r9 # reload argument
21985: movl (sp)+,r10 # restore xl
21986: rsb # return to prtvl caller
21987: #
21988: # HERE FOR TRBLK
21989: #
21990: prv04: movl 4*trval(r9),r9 # load real value
21991: jmp prv01 # and loop back
21992: #page
21993: #
21994: # PRTVL (CONTINUED)
21995: #
21996: # HERE FOR ARRAY (ARBLK)
21997: #
21998: # PRINT ARRAY ( PROTOTYPE ) BLANK NUMBER IDVAL
21999: #
22000: prv05: movl r9,r10 # preserve argument
22001: movl $scarr,r9 # point to datatype name (array)
22002: jsb prtst # print it
22003: movl $ch$pp,r6 # load left paren
22004: jsb prtch # print left paren
22005: addl2 4*arofs(r10),r10# point to prototype
22006: movl (r10),r9 # load prototype
22007: jsb prtst # print prototype
22008: #
22009: # VCBLK, TBBLK, BCBLK MERGE HERE FOR ) BLANK NUMBER IDVAL
22010: #
22011: prv06: movl $ch$rp,r6 # load right paren
22012: jsb prtch # print right paren
22013: #
22014: # PDBLK MERGES HERE TO PRINT BLANK NUMBER IDVAL
22015: #
22016: prv07: movl $ch$bl,r6 # load blank
22017: jsb prtch # print it
22018: movl $ch$nm,r6 # load number sign
22019: jsb prtch # print it
22020: movl prvsi,r5 # get idval
22021: jsb prtin # print id number
22022: jmp prv03 # back to exit
22023: #
22024: # HERE FOR INTEGER (ICBLK), REAL (RCBLK)
22025: #
22026: # PRINT CHARACTER REPRESENTATION OF VALUE
22027: #
22028: prv08: movl r9,-(sp) # stack argument for gtstg
22029: jsb gtstg # convert to string
22030: .long invalid$ # error return is impossible
22031: jsb prtst # print the string
22032: movl r9,dnamp # delete garbage string from storage
22033: jmp prv03 # back to exit
22034: #page
22035: #
22036: # PRTVL (CONTINUED)
22037: #
22038: # NAME (NMBLK)
22039: #
22040: # FOR PSEUDO-VARIABLE, JUST PRINT DATATYPE NAME (NAME)
22041: # FOR ALL OTHER NAMES, PRINT DOT FOLLOWED BY NAME REP
22042: #
22043: prv09: movl 4*nmbas(r9),r10 # load name base
22044: movl (r10),r6 # load first word of block
22045: cmpl r6,$b$kvt # just print name if keyword
22046: bnequ 0f
22047: jmp prv02
22048: 0:
22049: cmpl r6,$b$evt # just print name if expression var
22050: bnequ 0f
22051: jmp prv02
22052: 0:
22053: movl $ch$dt,r6 # else get dot
22054: jsb prtch # and print it
22055: movl 4*nmofs(r9),r6 # load name offset
22056: jsb prtnm # print name
22057: jmp prv03 # back to exit
22058: #
22059: # PROGRAM DATATYPE (PDBLK)
22060: #
22061: # PRINT DATATYPE NAME CH$BL CH$NM IDVAL
22062: #
22063: prv10: jsb dtype # get datatype name
22064: jsb prtst # print datatype name
22065: jmp prv07 # merge back to print id
22066: #
22067: # HERE FOR STRING (SCBLK)
22068: #
22069: # PRINT QUOTE STRING-CHARACTERS QUOTE
22070: #
22071: prv11: movl $ch$sq,r6 # load single quote
22072: jsb prtch # print quote
22073: jsb prtst # print string value
22074: jsb prtch # print another quote
22075: jmp prv03 # back to exit
22076: #page
22077: #
22078: # PRTVL (CONTINUED)
22079: #
22080: # HERE FOR SIMPLE EXPRESSION (SEBLK)
22081: #
22082: # PRINT ASTERISK VARIABLE-NAME
22083: #
22084: prv12: movl $ch$as,r6 # load asterisk
22085: jsb prtch # print asterisk
22086: movl 4*sevar(r9),r9 # load variable pointer
22087: jsb prtvn # print variable name
22088: jmp prv03 # jump back to exit
22089: #
22090: # HERE FOR TABLE (TBBLK) AND ARRAY (VCBLK)
22091: #
22092: # PRINT DATATYPE ( PROTOTYPE ) BLANK NUMBER IDVAL
22093: #
22094: prv13: movl r9,r10 # preserve argument
22095: jsb dtype # get datatype name
22096: jsb prtst # print datatype name
22097: movl $ch$pp,r6 # load left paren
22098: jsb prtch # print left paren
22099: movl 4*tblen(r10),r6 # load length of block (=vclen)
22100: ashl $-2,r6,r6 # convert to word count
22101: subl2 $tbsi$,r6 # allow for standard fields
22102: cmpl (r10),$b$tbt # jump if table
22103: beqlu prv14
22104: addl2 $vctbd,r6 # for vcblk, adjust size
22105: #
22106: # PRINT PROTOTYPE
22107: #
22108: prv14: movl r6,r5 # move as integer
22109: jsb prtin # print integer prototype
22110: jmp prv06 # merge back for rest
22111: #page
22112: #
22113: # PRTVL (CONTINUED)
22114: #
22115: # HERE FOR BUFFER (BCBLK)
22116: #
22117: prv15: movl r9,r10 # preserve argument
22118: movl $scbuf,r9 # point to datatype name (buffer)
22119: jsb prtst # print it
22120: movl $ch$pp,r6 # load left paren
22121: jsb prtch # print left paren
22122: movl 4*bcbuf(r10),r9 # point to bfblk
22123: movl 4*bfalc(r9),r5 # load allocation size
22124: jsb prtin # print it
22125: movl $ch$cm,r6 # load comma
22126: jsb prtch # print it
22127: movl 4*bclen(r10),r5 # load defined length
22128: jsb prtin # print it
22129: jmp prv06 # merge to finish up
22130: #enp # end procedure prtvl
22131: #page
22132: #
22133: # PRTVN -- PRINT NATURAL VARIABLE NAME
22134: #
22135: # PRTVN PRINTS THE NAME OF A NATURAL VARIABLE
22136: #
22137: # (XR) POINTER TO VRBLK
22138: # JSR PRTVN CALL TO PRINT VARIABLE NAME
22139: #
22140: prtvn: #prc # entry point
22141: movl r9,-(sp) # stack vrblk pointer
22142: addl2 $4*vrsof,r9 # point to possible string name
22143: tstl 4*sclen(r9) # jump if not system variable
22144: bnequ prvn1
22145: movl 4*vrsvo(r9),r9 # point to svblk with name
22146: #
22147: # MERGE HERE WITH DUMMY SCBLK POINTER IN XR
22148: #
22149: prvn1: jsb prtst # print string name of variable
22150: movl (sp)+,r9 # restore vrblk pointer
22151: rsb # return to prtvn caller
22152: #enp # end procedure prtvn
22153: #page
22154: #
22155: # RCBLD -- BUILD A REAL BLOCK
22156: #
22157: # (RA) REAL VALUE FOR RCBLK
22158: # JSR RCBLD CALL TO BUILD REAL BLOCK
22159: # (XR) POINTER TO RESULT RCBLK
22160: # (WA) DESTROYED
22161: #
22162: rcbld: #prc # entry point
22163: movl dnamp,r9 # load pointer to next available loc
22164: addl2 $4*rcsi$,r9 # point past new rcblk
22165: cmpl r9,dname # jump if there is room
22166: blequ rcbl1
22167: movl $4*rcsi$,r6 # else load rcblk length
22168: jsb alloc # use standard allocator to get block
22169: addl2 r6,r9 # point past block to merge
22170: #
22171: # MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
22172: #
22173: rcbl1: movl r9,dnamp # set new pointer
22174: subl2 $4*rcsi$,r9 # point back to start of block
22175: movl $b$rcl,(r9) # store type word
22176: movf r2,4*rcval(r9) # store real value in rcblk
22177: rsb # return to rcbld caller
22178: #enp # end procedure rcbld
22179: #page
22180: #
22181: # READR -- READ NEXT SOURCE IMAGE AT COMPILE TIME
22182: #
22183: # READR IS USED TO READ THE NEXT SOURCE IMAGE. TO PROCESS
22184: # CONTINUATION CARDS PROPERLY, THE COMPILER MUST READ ONE
22185: # LINE AHEAD. THUS READR DOES NOT DESTROY THE CURRENT IMAGE
22186: # SEE ALSO THE NEXTS ROUTINE WHICH ACTUALLY GETS THE IMAGE.
22187: #
22188: # JSR READR CALL TO READ NEXT IMAGE
22189: # (XR) PTR TO NEXT IMAGE (0 IF NONE)
22190: # (R$CNI) COPY OF POINTER
22191: # (WA,WB,WC,XL) DESTROYED
22192: #
22193: readr: #prc # entry point
22194: movl r$cni,r9 # get ptr to next image
22195: tstl r9 # exit if already read
22196: bnequ read3
22197: cmpl stage,$stgic # exit if not initial compile
22198: bnequ read3
22199: movl cswin,r6 # max read length
22200: jsb alocs # allocate buffer
22201: jsb sysrd # read input image
22202: .long read4 # jump if end of file
22203: movl sp,r7 # set trimr to perform trim
22204: cmpl 4*sclen(r9),cswin# use smaller of string lnth ..
22205: blequ read1
22206: movl cswin,4*sclen(r9)# ... and xxx of -inxxx
22207: #
22208: # PERFORM THE TRIM
22209: #
22210: read1: jsb trimr # trim trailing blanks
22211: #
22212: # MERGE HERE AFTER READ
22213: #
22214: read2: movl r9,r$cni # store copy of pointer
22215: #
22216: # MERGE HERE IF NO READ ATTEMPTED
22217: #
22218: read3: rsb # return to readr caller
22219: #
22220: # HERE ON END OF FILE
22221: #
22222: read4: movl r9,dnamp # pop unused scblk
22223: clrl r9 # zero ptr as result
22224: jmp read2 # merge
22225: #enp # end procedure readr
22226: #page
22227: #
22228: # SBSTR -- BUILD A SUBSTRING
22229: #
22230: # (XL) PTR TO SCBLK/BFBLK WITH CHARS
22231: # (WA) NUMBER OF CHARS IN SUBSTRING
22232: # (WB) OFFSET TO FIRST CHAR IN SCBLK
22233: # JSR SBSTR CALL TO BUILD SUBSTRING
22234: # (XR) PTR TO NEW SCBLK WITH SUBSTRING
22235: # (XL) ZERO
22236: # (WA,WB,WC,XL,IA) DESTROYED
22237: #
22238: # NOTE THAT SBSTR IS CALLED WITH A DUMMY STRING POINTER
22239: # (POINTING INTO A VRBLK OR SVBLK) TO COPY THE NAME OF A
22240: # VARIABLE AS A STANDARD STRING VALUE.
22241: #
22242: sbstr: #prc # entry point
22243: tstl r6 # jump if null substring
22244: beqlu sbst2
22245: jsb alocs # else allocate scblk
22246: movl r8,r6 # move number of characters
22247: movl r9,r8 # save ptr to new scblk
22248: movab cfp$f(r10)[r7],r10 # prepare to load chars from old blk
22249: movab cfp$f(r9),r9 # prepare to store chars in new blk
22250: jsb sbmvc # move characters to new string
22251: movl r8,r9 # then restore scblk pointer
22252: #
22253: # RETURN POINT
22254: #
22255: sbst1: clrl r10 # clear garbage pointer in xl
22256: rsb # return to sbstr caller
22257: #
22258: # HERE FOR NULL SUBSTRING
22259: #
22260: sbst2: movl $nulls,r9 # set null string as result
22261: jmp sbst1 # return
22262: #enp # end procedure sbstr
22263: #page
22264: #
22265: # SCANE -- SCAN AN ELEMENT
22266: #
22267: # SCANE IS CALLED AT COMPILE TIME (BY EXPAN ,CMPIL,CNCRD)
22268: # TO SCAN ONE ELEMENT FROM THE INPUT IMAGE.
22269: #
22270: # (SCNCC) NON-ZERO IF CALLED FROM CNCRD
22271: # JSR SCANE CALL TO SCAN ELEMENT
22272: # (XR) RESULT POINTER (SEE BELOW)
22273: # (XL) SYNTAX TYPE CODE (T$XXX)
22274: #
22275: # THE FOLLOWING GLOBAL LOCATIONS ARE USED.
22276: #
22277: # R$CIM POINTER TO STRING BLOCK (SCBLK)
22278: # FOR CURRENT INPUT IMAGE.
22279: #
22280: # R$CNI POINTER TO NEXT INPUT IMAGE STRING
22281: # POINTER (ZERO IF NONE).
22282: #
22283: # R$SCP SAVE POINTER (EXIT XR) FROM LAST
22284: # CALL IN CASE RESCAN IS SET.
22285: #
22286: # SCNBL THIS LOCATION IS SET NON-ZERO ON
22287: # EXIT IF SCANE SCANNED PAST BLANKS
22288: # BEFORE LOCATING THE CURRENT ELEMENT
22289: # THE END OF A LINE COUNTS AS BLANKS.
22290: #
22291: # SCNCC CNCRD SETS THIS NON-ZERO TO SCAN
22292: # CONTROL CARD NAMES AND CLEARS IT
22293: # ON RETURN
22294: #
22295: # SCNIL LENGTH OF CURRENT INPUT IMAGE
22296: #
22297: # SCNGO IF SET NON-ZERO ON ENTRY, F AND S
22298: # ARE RETURNED AS SEPARATE SYNTAX
22299: # TYPES (NOT LETTERS) (GOTO PRO-
22300: # CESSING). SCNGO IS RESET ON EXIT.
22301: #
22302: # SCNPT OFFSET TO CURRENT LOC IN R$CIM
22303: #
22304: # SCNRS IF SET NON-ZERO ON ENTRY, SCANE
22305: # RETURNS THE SAME RESULT AS ON THE
22306: # LAST CALL (RESCAN). SCNRS IS RESET
22307: # ON EXIT FROM ANY CALL TO SCANE.
22308: #
22309: # SCNTP SAVE SYNTAX TYPE FROM LAST
22310: # CALL (IN CASE RESCAN IS SET).
22311: #page
22312: #
22313: # SCANE (CONTINUED)
22314: #
22315: #
22316: #
22317: # ELEMENT SCANNED XL XR
22318: # --------------- -- --
22319: #
22320: # CONTROL CARD NAME 0 POINTER TO SCBLK FOR NAME
22321: #
22322: # UNARY OPERATOR T$UOP PTR TO OPERATOR DVBLK
22323: #
22324: # LEFT PAREN T$LPR T$LPR
22325: #
22326: # LEFT BRACKET T$LBR T$LBR
22327: #
22328: # COMMA T$CMA T$CMA
22329: #
22330: # FUNCTION CALL T$FNC PTR TO FUNCTION VRBLK
22331: #
22332: # VARIABLE T$VAR PTR TO VRBLK
22333: #
22334: # STRING CONSTANT T$CON PTR TO SCBLK
22335: #
22336: # INTEGER CONSTANT T$CON PTR TO ICBLK
22337: #
22338: # REAL CONSTANT T$CON PTR TO RCBLK
22339: #
22340: # BINARY OPERATOR T$BOP PTR TO OPERATOR DVBLK
22341: #
22342: # RIGHT PAREN T$RPR T$RPR
22343: #
22344: # RIGHT BRACKET T$RBR T$RBR
22345: #
22346: # COLON T$COL T$COL
22347: #
22348: # SEMI-COLON T$SMC T$SMC
22349: #
22350: # F (SCNGO NE 0) T$FGO T$FGO
22351: #
22352: # S (SCNGO NE 0) T$SGO T$SGO
22353: #page
22354: #
22355: # SCANE (CONTINUED)
22356: #
22357: # ENTRY POINT
22358: #
22359: scane: #prc # entry point
22360: clrl scnbl # reset blanks flag
22361: movl r6,scnsa # save wa
22362: movl r7,scnsb # save wb
22363: movl r8,scnsc # save wc
22364: tstl scnrs # jump if no rescan
22365: beqlu scn03
22366: #
22367: # HERE FOR RESCAN REQUEST
22368: #
22369: movl scntp,r10 # set previous returned scan type
22370: movl r$scp,r9 # set previous returned pointer
22371: clrl scnrs # reset rescan switch
22372: jmp scn13 # jump to exit
22373: #
22374: # COME HERE TO READ NEW IMAGE TO TEST FOR CONTINUATION
22375: #
22376: scn01: jsb readr # read next image
22377: movl $4*dvubs,r7 # set wb for not reading name
22378: tstl r9 # treat as semi-colon if none
22379: bnequ 0f
22380: jmp scn30
22381: 0:
22382: movab cfp$f(r9),r9 # else point to first character
22383: movzbl (r9),r8 # load first character
22384: cmpl r8,$ch$dt # jump if dot for continuation
22385: beqlu scn02
22386: cmpl r8,$ch$pl # else treat as semicolon unless plus
22387: beqlu 0f
22388: jmp scn30
22389: 0:
22390: #
22391: # HERE FOR CONTINUATION LINE
22392: #
22393: scn02: jsb nexts # acquire next source image
22394: movl $num01,scnpt # set scan pointer past continuation
22395: movl sp,scnbl # set blanks flag
22396: #page
22397: #
22398: # SCANE (CONTINUED)
22399: #
22400: # MERGE HERE TO SCAN NEXT ELEMENT ON CURRENT LINE
22401: #
22402: scn03: movl scnpt,r6 # load current offset
22403: cmpl r6,scnil # check continuation if end
22404: bnequ 0f
22405: jmp scn01
22406: 0:
22407: movl r$cim,r10 # point to current line
22408: movab cfp$f(r10)[r6],r10 # point to current character
22409: movl r6,scnse # set start of element location
22410: movl $opdvs,r8 # point to operator dv list
22411: movl $4*dvubs,r7 # set constant for operator circuit
22412: jmp scn06 # start scanning
22413: #
22414: # LOOP HERE TO IGNORE LEADING BLANKS AND TABS
22415: #
22416: scn05: tstl r7 # jump if trailing
22417: bnequ 0f
22418: jmp scn10
22419: 0:
22420: incl scnse # increment start of element
22421: cmpl r6,scnil # jump if end of image
22422: bnequ 0f
22423: jmp scn01
22424: 0:
22425: movl sp,scnbl # note blanks seen
22426: #
22427: # THE FOLLOWING JUMP IS USED REPEATEDLY FOR SCANNING OUT
22428: # THE CHARACTERS OF A NUMERIC CONSTANT OR VARIABLE NAME.
22429: # THE REGISTERS ARE USED AS FOLLOWS.
22430: #
22431: # (XR) SCRATCH
22432: # (XL) PTR TO NEXT CHARACTER
22433: # (WA) CURRENT SCAN OFFSET
22434: # (WB) *DVUBS (0 IF SCANNING NAME,CONST)
22435: # (WC) =OPDVS (0 IF SCANNING CONSTANT)
22436: #
22437: scn06: movzbl (r10)+,r9 # get next character
22438: incl r6 # bump scan offset
22439: movl r6,scnpt # store offset past char scanned
22440: cmpl $cfp$u,r9 # quick check for other char
22441: bgtru 0f
22442: jmp scn07
22443: 0:
22444: casel r9,$0,$cfp$u # switch on scanned character
22445: 5:
22446: #
22447: # SWITCH TABLE FOR SWITCH ON CHARACTER
22448: #
22449: #page
22450: #
22451: # SCANE (CONTINUED)
22452: #
22453: #page
22454: #
22455: # SCANE (CONTINUED)
22456: #
22457: .word scn07-5b
22458: .word scn07-5b
22459: .word scn07-5b
22460: .word scn07-5b
22461: .word scn07-5b
22462: .word scn07-5b
22463: .word scn07-5b
22464: .word scn07-5b
22465: .word scn07-5b
22466: .word scn05-5b # horizontal tab
22467: .word scn07-5b
22468: .word scn07-5b
22469: .word scn07-5b
22470: .word scn07-5b
22471: .word scn07-5b
22472: .word scn07-5b
22473: .word scn07-5b
22474: .word scn07-5b
22475: .word scn07-5b
22476: .word scn07-5b
22477: .word scn07-5b
22478: .word scn07-5b
22479: .word scn07-5b
22480: .word scn07-5b
22481: .word scn07-5b
22482: .word scn07-5b
22483: .word scn07-5b
22484: .word scn07-5b
22485: .word scn07-5b
22486: .word scn07-5b
22487: .word scn07-5b
22488: .word scn07-5b
22489: .word scn05-5b # blank
22490: .word scn37-5b # exclamation mark
22491: .word scn17-5b # double quote
22492: .word scn41-5b # number sign
22493: .word scn36-5b # dollar
22494: .word scn38-5b # percent
22495: .word scn44-5b # ampersand
22496: .word scn16-5b # single quote
22497: .word scn25-5b # left paren
22498: .word scn26-5b # right paren
22499: .word scn49-5b # asterisk
22500: .word scn33-5b # plus
22501: .word scn31-5b # comma
22502: .word scn34-5b # minus
22503: .word scn32-5b # dot
22504: .word scn40-5b # slash
22505: .word scn08-5b # digit 0
22506: .word scn08-5b # digit 1
22507: .word scn08-5b # digit 2
22508: .word scn08-5b # digit 3
22509: .word scn08-5b # digit 4
22510: .word scn08-5b # digit 5
22511: .word scn08-5b # digit 6
22512: .word scn08-5b # digit 7
22513: .word scn08-5b # digit 8
22514: .word scn08-5b # digit 9
22515: .word scn29-5b # colon
22516: .word scn30-5b # semi-colon
22517: .word scn28-5b # left bracket
22518: .word scn46-5b # equal
22519: .word scn27-5b # right bracket
22520: .word scn45-5b # question mark
22521: .word scn42-5b # at
22522: .word scn09-5b # letter a
22523: .word scn09-5b # letter b
22524: .word scn09-5b # letter c
22525: .word scn09-5b # letter d
22526: .word scn09-5b # letter e
22527: .word scn20-5b # letter f
22528: .word scn09-5b # letter g
22529: .word scn09-5b # letter h
22530: .word scn09-5b # letter i
22531: .word scn09-5b # letter j
22532: .word scn09-5b # letter k
22533: .word scn09-5b # letter l
22534: .word scn09-5b # letter m
22535: .word scn09-5b # letter n
22536: .word scn09-5b # letter o
22537: .word scn09-5b # letter p
22538: .word scn09-5b # letter q
22539: .word scn09-5b # letter r
22540: .word scn21-5b # letter s
22541: .word scn09-5b # letter t
22542: .word scn09-5b # letter u
22543: .word scn09-5b # letter v
22544: .word scn09-5b # letter w
22545: .word scn09-5b # letter x
22546: .word scn09-5b # letter y
22547: .word scn09-5b # letter z
22548: .word scn28-5b # left bracket
22549: .word scn07-5b
22550: .word scn27-5b # right bracket
22551: .word scn07-5b
22552: .word scn24-5b # underline
22553: .word scn07-5b
22554: .word scn09-5b # shifted a
22555: .word scn09-5b # shifted b
22556: .word scn09-5b # shifted c
22557: .word scn09-5b # shifted d
22558: .word scn09-5b # shifted e
22559: .word scn20-5b # shifted f
22560: .word scn09-5b # shifted g
22561: .word scn09-5b # shifted h
22562: .word scn09-5b # shifted i
22563: .word scn09-5b # shifted j
22564: .word scn09-5b # shifted k
22565: .word scn09-5b # shifted l
22566: .word scn09-5b # shifted m
22567: .word scn09-5b # shifted n
22568: .word scn09-5b # shifted o
22569: .word scn09-5b # shifted p
22570: .word scn09-5b # shifted q
22571: .word scn09-5b # shifted r
22572: .word scn21-5b # shifted s
22573: .word scn09-5b # shifted t
22574: .word scn09-5b # shifted u
22575: .word scn09-5b # shifted v
22576: .word scn09-5b # shifted w
22577: .word scn09-5b # shifted x
22578: .word scn09-5b # shifted y
22579: .word scn09-5b # shifted z
22580: .word scn07-5b
22581: .word scn43-5b # vertical bar
22582: .word scn07-5b
22583: .word scn35-5b # not
22584: .word scn07-5b
22585: #esw # end switch on character
22586: #
22587: # HERE FOR ILLEGAL CHARACTER (UNDERLINE MERGES)
22588: #
22589: scn07: tstl r7 # jump if scanning name or constant
22590: bnequ 0f
22591: jmp scn10
22592: 0:
22593: jmp er_230 # syntax error. illegal character
22594: #page
22595: #
22596: # SCANE (CONTINUED)
22597: #
22598: # HERE FOR DIGITS 0-9
22599: #
22600: scn08: tstl r7 # keep scanning if name/constant
22601: bnequ 0f
22602: jmp scn09
22603: 0:
22604: clrl r8 # else set flag for scanning constant
22605: #
22606: # HERE FOR LETTER. LOOP HERE WHEN SCANNING NAME/CONSTANT
22607: #
22608: scn09: cmpl r6,scnil # jump if end of image
22609: beqlu scn11
22610: clrl r7 # set flag for scanning name/const
22611: jmp scn06 # merge back to continue scan
22612: #
22613: # COME HERE FOR DELIMITER ENDING NAME OR CONSTANT
22614: #
22615: scn10: decl r6 # reset offset to point to delimiter
22616: #
22617: # COME HERE AFTER FINISHING SCAN OF NAME OR CONSTANT
22618: #
22619: scn11: movl r6,scnpt # store updated scan offset
22620: movl scnse,r7 # point to start of element
22621: subl2 r7,r6 # get number of characters
22622: movl r$cim,r10 # point to line image
22623: tstl r8 # jump if name
22624: bnequ scn15
22625: #
22626: # HERE AFTER SCANNING OUT NUMERIC CONSTANT
22627: #
22628: jsb sbstr # get string for constant
22629: movl r9,dnamp # delete from storage (not needed)
22630: jsb gtnum # convert to numeric
22631: .long scn14 # jump if conversion failure
22632: #
22633: # MERGE HERE TO EXIT WITH CONSTANT
22634: #
22635: scn12: movl $t$con,r10 # set result type of constant
22636: #page
22637: #
22638: # SCANE (CONTINUED)
22639: #
22640: # COMMON EXIT POINT (XR,XL) SET
22641: #
22642: scn13: movl scnsa,r6 # restore wa
22643: movl scnsb,r7 # restore wb
22644: movl scnsc,r8 # restore wc
22645: movl r9,r$scp # save xr in case rescan
22646: movl r10,scntp # save xl in case rescan
22647: clrl scngo # reset possible goto flag
22648: rsb # return to scane caller
22649: #
22650: # HERE IF CONVERSION ERROR ON NUMERIC ITEM
22651: #
22652: scn14: jmp er_231 # syntax error. invalid numeric item
22653: #
22654: # HERE AFTER SCANNING OUT VARIABLE NAME
22655: #
22656: scn15: jsb sbstr # build string name of variable
22657: tstl scncc # return if cncrd call
22658: beqlu 0f
22659: jmp scn13
22660: 0:
22661: jsb gtnvr # locate/build vrblk
22662: .long invalid$ # dummy (unused) error return
22663: movl $t$var,r10 # set type as variable
22664: jmp scn13 # back to exit
22665: #
22666: # HERE FOR SINGLE QUOTE (START OF STRING CONSTANT)
22667: #
22668: scn16: tstl r7 # terminator if scanning name or cnst
22669: bnequ 0f
22670: jmp scn10
22671: 0:
22672: movl $ch$sq,r7 # set terminator as single quote
22673: jmp scn18 # merge
22674: #
22675: # HERE FOR DOUBLE QUOTE (START OF STRING CONSTANT)
22676: #
22677: scn17: tstl r7 # terminator if scanning name or cnst
22678: bnequ 0f
22679: jmp scn10
22680: 0:
22681: movl $ch$dq,r7 # set double quote terminator, merge
22682: #
22683: # LOOP TO SCAN OUT STRING CONSTANT
22684: #
22685: scn18: cmpl r6,scnil # error if end of image
22686: beqlu scn19
22687: movzbl (r10)+,r8 # else load next character
22688: incl r6 # bump offset
22689: cmpl r8,r7 # loop back if not terminator
22690: bnequ scn18
22691: #page
22692: #
22693: # SCANE (CONTINUED)
22694: #
22695: # HERE AFTER SCANNING OUT STRING CONSTANT
22696: #
22697: movl scnpt,r7 # point to first character
22698: movl r6,scnpt # save offset past final quote
22699: decl r6 # point back past last character
22700: subl2 r7,r6 # get number of characters
22701: movl r$cim,r10 # point to input image
22702: jsb sbstr # build substring value
22703: jmp scn12 # back to exit with constant result
22704: #
22705: # HERE IF NO MATCHING QUOTE FOUND
22706: #
22707: scn19: movl r6,scnpt # set updated scan pointer
22708: jmp er_232 # syntax error. unmatched string quote
22709: #
22710: # HERE FOR F (POSSIBLE FAILURE GOTO)
22711: #
22712: scn20: movl $t$fgo,r9 # set return code for fail goto
22713: jmp scn22 # jump to merge
22714: #
22715: # HERE FOR S (POSSIBLE SUCCESS GOTO)
22716: #
22717: scn21: movl $t$sgo,r9 # set success goto as return code
22718: #
22719: # SPECIAL GOTO CASES MERGE HERE
22720: #
22721: scn22: tstl scngo # treat as normal letter if not goto
22722: bnequ 0f
22723: jmp scn09
22724: 0:
22725: #
22726: # MERGE HERE FOR SPECIAL CHARACTER EXIT
22727: #
22728: scn23: tstl r7 # jump if end of name/constant
22729: bnequ 0f
22730: jmp scn10
22731: 0:
22732: movl r9,r10 # else copy code
22733: jmp scn13 # and jump to exit
22734: #
22735: # HERE FOR UNDERLINE
22736: #
22737: scn24: tstl r7 # part of name if scanning name
22738: bnequ 0f
22739: jmp scn09
22740: 0:
22741: jmp scn07 # else illegal
22742: #page
22743: #
22744: # SCANE (CONTINUED)
22745: #
22746: # HERE FOR LEFT PAREN
22747: #
22748: scn25: movl $t$lpr,r9 # set left paren return code
22749: tstl r7 # return left paren unless name
22750: bnequ scn23
22751: tstl r8 # delimiter if scanning constant
22752: bnequ 0f
22753: jmp scn10
22754: 0:
22755: #
22756: # HERE FOR LEFT PAREN AFTER NAME (FUNCTION CALL)
22757: #
22758: movl scnse,r7 # point to start of name
22759: movl r6,scnpt # set pointer past left paren
22760: decl r6 # point back past last char of name
22761: subl2 r7,r6 # get name length
22762: movl r$cim,r10 # point to input image
22763: jsb sbstr # get string name for function
22764: jsb gtnvr # locate/build vrblk
22765: .long invalid$ # dummy (unused) error return
22766: movl $t$fnc,r10 # set code for function call
22767: jmp scn13 # back to exit
22768: #
22769: # PROCESSING FOR SPECIAL CHARACTERS
22770: #
22771: scn26: movl $t$rpr,r9 # right paren, set code
22772: jmp scn23 # take special character exit
22773: #
22774: scn27: movl $t$rbr,r9 # right bracket, set code
22775: jmp scn23 # take special character exit
22776: #
22777: scn28: movl $t$lbr,r9 # left bracket, set code
22778: jmp scn23 # take special character exit
22779: #
22780: scn29: movl $t$col,r9 # colon, set code
22781: jmp scn23 # take special character exit
22782: #
22783: scn30: movl $t$smc,r9 # semi-colon, set code
22784: jmp scn23 # take special character exit
22785: #
22786: scn31: movl $t$cma,r9 # comma, set code
22787: jmp scn23 # take special character exit
22788: #page
22789: #
22790: # SCANE (CONTINUED)
22791: #
22792: # HERE FOR OPERATORS. ON ENTRY, WC POINTS TO THE TABLE OF
22793: # OPERATOR DOPE VECTORS AND WB IS THE INCREMENT TO STEP
22794: # TO THE NEXT PAIR (BINARY/UNARY) OF DOPE VECTORS IN THE
22795: # LIST. ON REACHING SCN46, THE POINTER HAS BEEN ADJUSTED TO
22796: # POINT TO THE APPROPRIATE PAIR OF DOPE VECTORS.
22797: # THE FIRST THREE ENTRIES ARE SPECIAL SINCE THEY CAN OCCUR
22798: # AS PART OF A VARIABLE NAME (.) OR CONSTANT (.+-).
22799: #
22800: scn32: tstl r7 # dot can be part of name or constant
22801: bnequ 0f
22802: jmp scn09
22803: 0:
22804: addl2 r7,r8 # else bump pointer
22805: #
22806: scn33: tstl r8 # plus can be part of constant
22807: bnequ 0f
22808: jmp scn09
22809: 0:
22810: tstl r7 # plus cannot be part of name
22811: bnequ 0f
22812: jmp scn48
22813: 0:
22814: addl2 r7,r8 # else bump pointer
22815: #
22816: scn34: tstl r8 # minus can be part of constant
22817: bnequ 0f
22818: jmp scn09
22819: 0:
22820: tstl r7 # minus cannot be part of name
22821: bnequ 0f
22822: jmp scn48
22823: 0:
22824: addl2 r7,r8 # else bump pointer
22825: #
22826: scn35: addl2 r7,r8 # not
22827: scn36: addl2 r7,r8 # dollar
22828: scn37: addl2 r7,r8 # exclamation
22829: scn38: addl2 r7,r8 # percent
22830: scn39: addl2 r7,r8 # asterisk
22831: scn40: addl2 r7,r8 # slash
22832: scn41: addl2 r7,r8 # number sign
22833: scn42: addl2 r7,r8 # at sign
22834: scn43: addl2 r7,r8 # vertical bar
22835: scn44: addl2 r7,r8 # ampersand
22836: scn45: addl2 r7,r8 # question mark
22837: #
22838: # ALL OPERATORS COME HERE (EQUAL MERGES DIRECTLY)
22839: # (WC) POINTS TO THE BINARY/UNARY PAIR OF OPERATOR DVBLKS.
22840: #
22841: scn46: tstl r7 # operator terminates name/constant
22842: bnequ 0f
22843: jmp scn10
22844: 0:
22845: movl r8,r9 # else copy dv pointer
22846: movzbl (r10),r8 # load next character
22847: movl $t$bop,r10 # set binary op in case
22848: cmpl r6,scnil # should be binary if image end
22849: beqlu scn47
22850: cmpl r8,$ch$bl # should be binary if followed by blk
22851: beqlu scn47
22852: cmpl r8,$ch$ht # jump if horizontal tab
22853: beqlu scn47
22854: cmpl r8,$ch$sm # semicolon can immediately follow =
22855: beqlu scn47
22856: #
22857: # HERE FOR UNARY OPERATOR
22858: #
22859: addl2 $4*dvbs$,r9 # point to dv for unary op
22860: movl $t$uop,r10 # set type for unary operator
22861: cmpl scntp,$t$uok # ok unary if ok preceding element
22862: bgtru 0f
22863: jmp scn13
22864: 0:
22865: #page
22866: #
22867: # SCANE (CONTINUED)
22868: #
22869: # MERGE HERE TO REQUIRE PRECEDING BLANKS
22870: #
22871: scn47: tstl scnbl # all ok if preceding blanks, exit
22872: beqlu 0f
22873: jmp scn13
22874: 0:
22875: #
22876: # FAIL OPERATOR IN THIS POSITION
22877: #
22878: scn48: jmp er_233 # syntax error. invalid use of operator
22879: #
22880: # HERE FOR ASTERISK, COULD BE ** SUBSTITUTE FOR EXCLAMATION
22881: #
22882: scn49: tstl r7 # end of name if scanning name
22883: bnequ 0f
22884: jmp scn10
22885: 0:
22886: cmpl r6,scnil # not ** if * at image end
22887: beqlu scn39
22888: movl r6,r9 # else save offset past first *
22889: movl r6,scnof # save another copy
22890: movzbl (r10)+,r6 # load next character
22891: cmpl r6,$ch$as # not ** if next char not *
22892: bnequ scn50
22893: incl r9 # else step offset past second *
22894: cmpl r9,scnil # ok exclam if end of image
22895: beqlu scn51
22896: movzbl (r10),r6 # else load next character
22897: cmpl r6,$ch$bl # exclamation if blank
22898: beqlu scn51
22899: cmpl r6,$ch$ht # exclamation if horizontal tab
22900: beqlu scn51
22901: #
22902: # UNARY *
22903: #
22904: scn50: movl scnof,r6 # recover stored offset
22905: movl r$cim,r10 # point to line again
22906: movab cfp$f(r10)[r6],r10 # point to current char
22907: jmp scn39 # merge with unary *
22908: #
22909: # HERE FOR ** AS SUBSTITUTE FOR EXCLAMATION
22910: #
22911: scn51: movl r9,scnpt # save scan pointer past 2nd *
22912: movl r9,r6 # copy scan pointer
22913: jmp scn37 # merge with exclamation
22914: #enp # end procedure scane
22915: #page
22916: #
22917: # SCNGF -- SCAN GOTO FIELD
22918: #
22919: # SCNGF IS CALLED FROM CMPIL TO SCAN AND ANALYZE A GOTO
22920: # FIELD INCLUDING THE SURROUNDING BRACKETS OR PARENTHESES.
22921: # FOR A NORMAL GOTO, THE RESULT RETURNED IS EITHER A VRBLK
22922: # POINTER FOR A SIMPLE LABEL OPERAND, OR A POINTER TO AN
22923: # EXPRESSION TREE WITH A SPECIAL OUTER UNARY OPERATOR
22924: # (O$GOC). FOR A DIRECT GOTO, THE RESULT RETURNED IS A
22925: # POINTER TO AN EXPRESSION TREE WITH THE SPECIAL OUTER
22926: # UNARY OPERATOR O$GOD.
22927: #
22928: # JSR SCNGF CALL TO SCAN GOTO FIELD
22929: # (XR) RESULT (SEE ABOVE)
22930: # (XL,WA,WB,WC) DESTROYED
22931: #
22932: scngf: #prc # entry point
22933: jsb scane # scan initial element
22934: cmpl r10,$t$lpr # skip if left paren (normal goto)
22935: beqlu scng1
22936: cmpl r10,$t$lbr # skip if left bracket (direct goto)
22937: beqlu scng2
22938: jmp er_234 # syntax error. goto field incorrect
22939: #
22940: # HERE FOR LEFT PAREN (NORMAL GOTO)
22941: #
22942: scng1: movl $num01,r7 # set expan flag for normal goto
22943: jsb expan # analyze goto field
22944: movl $opdvn,r6 # point to opdv for complex goto
22945: cmpl r9,statb # jump if not in static (sgd15)
22946: blequ scng3
22947: cmpl r9,state # jump to exit if simple label name
22948: blequ scng4
22949: jmp scng3 # complex goto - merge
22950: #
22951: # HERE FOR LEFT BRACKET (DIRECT GOTO)
22952: #
22953: scng2: movl $num02,r7 # set expan flag for direct goto
22954: jsb expan # scan goto field
22955: movl $opdvd,r6 # set opdv pointer for direct goto
22956: #page
22957: #
22958: # SCNGF (CONTINUED)
22959: #
22960: # MERGE HERE TO BUILD OUTER UNARY OPERATOR BLOCK
22961: #
22962: scng3: movl r6,-(sp) # stack operator dv pointer
22963: movl r9,-(sp) # stack pointer to expression tree
22964: jsb expop # pop operator off
22965: movl (sp)+,r9 # reload new expression tree pointer
22966: #
22967: # COMMON EXIT POINT
22968: #
22969: scng4: rsb # return to caller
22970: #enp # end procedure scngf
22971: #page
22972: #
22973: # SETVR -- SET VRGET,VRSTO FIELDS OF VRBLK
22974: #
22975: # SETVR SETS THE PROPER VALUES IN THE VRGET AND VRSTO
22976: # FIELDS OF A VRBLK. IT IS CALLED WHENEVER TRBLKS ARE
22977: # ADDED OR SUBTRACTED (TRACE,STOPTR,INPUT,OUTPUT,DETACH)
22978: #
22979: # (XR) POINTER TO VRBLK
22980: # JSR SETVR CALL TO SET FIELDS
22981: # (XL,WA) DESTROYED
22982: #
22983: # NOTE THAT SETVR IGNORES THE CALL IF XR DOES NOT POINT
22984: # INTO THE STATIC REGION (I.E. IS SOME OTHER NAME BASE)
22985: #
22986: setvr: #prc # entry point
22987: cmpl r9,state # exit if not natural variable
22988: bgequ setv1
22989: #
22990: # HERE IF WE HAVE A VRBLK
22991: #
22992: movl r9,r10 # copy vrblk pointer
22993: movl $b$vrl,4*vrget(r9) # store normal get value
22994: cmpl 4*vrsto(r9),$b$vre # skip if protected variable
22995: beqlu setv1
22996: movl $b$vrs,4*vrsto(r9) # store normal store value
22997: movl 4*vrval(r10),r10# point to next entry on chain
22998: cmpl (r10),$b$trt # jump if end of trblk chain
22999: bnequ setv1
23000: movl $b$vra,4*vrget(r9) # store trapped routine address
23001: movl $b$vrv,4*vrsto(r9) # set trapped routine address
23002: #
23003: # MERGE HERE TO EXIT TO CALLER
23004: #
23005: setv1: rsb # return to setvr caller
23006: #enp # end procedure setvr
23007: #page
23008: #
23009: # SORTA -- SORT ARRAY
23010: #
23011: # ROUTINE TO SORT AN ARRAY OR TABLE ON SAME BASIS AS IN
23012: # SITBOL. A TABLE IS CONVERTED TO AN ARRAY, LEAVING TWO
23013: # DIMENSIONAL ARRAYS AND VECTORS AS CASES TO BE CONSIDERED.
23014: # WHOLE ROWS OF ARRAYS ARE PERMUTED ACCORDING TO THE
23015: # ORDERING OF THE KEYS THEY CONTAIN, AND THE STRIDE
23016: # REFERRED TO, IS THE THE LENGTH OF A ROW. IT IS ONE
23017: # FOR A VECTOR.
23018: # THE SORT USED IS HEAPSORT, FUNDAMENTALS OF DATA STRUCTURE
23019: # HOROWITZ AND SAHNI, PITMAN 1977, PAGE 347.
23020: # IT IS AN ORDER N*LOG(N) ALGORITHM. IN ORDER
23021: # TO MAKE IT STABLE, COMPARANDS MAY NOT COMPARE EQUAL. THIS
23022: # IS ACHIEVED BY SORTING A COPY ARRAY (REFERRED TO AS THE
23023: # SORT ARRAY) CONTAINING AT ITS HIGH ADDRESS END, BYTE
23024: # OFFSETS TO THE ROWS TO BE SORTED HELD IN THE ORIGINAL
23025: # ARRAY (REFERRED TO AS THE KEY ARRAY). SORTC, THE
23026: # COMPARISON ROUTINE, ACCESSES THE KEYS THROUGH THESE
23027: # OFFSETS AND IN THE CASE OF EQUALITY, RESOLVES IT BY
23028: # COMPARING THE OFFSETS THEMSELVES. THE SORT PERMUTES THE
23029: # OFFSETS WHICH ARE THEN USED IN A FINAL OPERATION TO COPY
23030: # THE ACTUAL ITEMS INTO THE NEW ARRAY IN SORTED ORDER.
23031: # REFERENCES TO ZEROTH ITEM ARE TO NOTIONAL ITEM
23032: # PRECEDING FIRST ACTUAL ITEM.
23033: # REVERSE SORTING FOR RSORT IS DONE BY HAVING THE LESS THAN
23034: # TEST FOR KEYS EFFECTIVELY BE REPLACED BY A
23035: # GREATER THAN TEST.
23036: #
23037: # 1(XS) FIRST ARG - ARRAY OR TABLE
23038: # 0(XS) 2ND ARG - INDEX OR PDTYPE NAME
23039: # (WA) 0 , NON-ZERO FOR SORT , RSORT
23040: # JSR SORTA CALL TO SORT ARRAY
23041: # (XR) SORTED ARRAY
23042: # (XL,WA,WB,WC) DESTROYED
23043: #page
23044: #
23045: # SORTA (CONTINUED)
23046: #
23047: .data 1
23048: sorta_s: .long 0
23049: .text 0
23050: sorta: movl (sp)+,sorta_s # entry point
23051: movl r6,srtsr # sort/rsort indicator
23052: movl $4*num01,srtst # default stride of 1
23053: clrl srtof # default zero offset to sort key
23054: movl $nulls,srtdf # clear datatype field name
23055: movl (sp)+,r$sxr # unstack argument 2
23056: movl (sp)+,r9 # get first argument
23057: jsb gtarr # convert to array
23058: .long srt16 # fail
23059: movl r9,-(sp) # stack ptr to resulting key array
23060: movl r9,-(sp) # another copy for copyb
23061: jsb copyb # get copy array for sorting into
23062: .long invalid$ # cant fail
23063: movl r9,-(sp) # stack pointer to sort array
23064: movl r$sxr,r9 # get second arg
23065: movl 4*1(sp),r10 # get ptr to key array
23066: cmpl (r10),$b$vct # jump if arblk
23067: bnequ srt02
23068: cmpl r9,$nulls # jump if null second arg
23069: beqlu srt01
23070: jsb gtnvr # get vrblk ptr for it
23071: .long er_257 # erroneous 2nd arg in sort/rsort of vector
23072: movl r9,srtdf # store datatype field name vrblk
23073: #
23074: # COMPUTE N AND OFFSET TO ITEM A(0) IN VECTOR CASE
23075: #
23076: srt01: movl $4*vclen,r8 # offset to a(0)
23077: movl $4*vcvls,r7 # offset to first item
23078: movl 4*vclen(r10),r6 # get block length
23079: subl2 $4*vcsi$,r6 # get no. of entries, n (in bytes)
23080: jmp srt04 # merge
23081: #
23082: # HERE FOR ARRAY
23083: #
23084: srt02: movl 4*ardim(r10),r5 # get possible dimension
23085: movl r5,r6 # convert to short integer
23086: moval 0[r6],r6 # further convert to baus
23087: movl $4*arvls,r7 # offset to first value if one
23088: movl $4*arpro,r8 # offset before values if one dim.
23089: cmpl 4*arndm(r10),$num01 # jump in fact if one dim.
23090: bnequ 0f
23091: jmp srt04
23092: 0:
23093: cmpl 4*arndm(r10),$num02 # fail unless two dimens
23094: beqlu 0f
23095: jmp srt16
23096: 0:
23097: movl 4*arlb2(r10),r5 # get lower bound 2 as default
23098: cmpl r9,$nulls # jump if default second arg
23099: beqlu srt03
23100: jsb gtint # convert to integer
23101: .long srt17 # fail
23102: movl 4*icval(r9),r5 # get actual integer value
23103: #page
23104: #
23105: # SORTA (CONTINUED)
23106: #
23107: # HERE WITH SORT COLUMN INDEX IN IA IN ARRAY CASE
23108: #
23109: srt03: subl2 4*arlb2(r10),r5 # subtract low bound
23110: bvc 0f
23111: jmp srt17
23112: 0:
23113: tstl r5 # fail if below low bound
23114: bgeq 0f
23115: jmp srt17
23116: 0:
23117: subl2 4*ardm2(r10),r5 # check against dimension
23118: tstl r5 # fail if too large
23119: blss 0f
23120: jmp srt17
23121: 0:
23122: addl2 4*ardm2(r10),r5 # restore value
23123: movl r5,r6 # get as small integer
23124: moval 0[r6],r6 # offset within row to key
23125: movl r6,srtof # keep offset
23126: movl 4*ardm2(r10),r5 # second dimension is row length
23127: movl r5,r6 # convert to short integer
23128: movl r6,r9 # copy row length
23129: moval 0[r6],r6 # convert to bytes
23130: movl r6,srtst # store as stride
23131: movl 4*ardim(r10),r5 # get number of rows
23132: movl r5,r6 # as a short integer
23133: moval 0[r6],r6 # convert n to baus
23134: movl 4*arlen(r10),r8 # offset past array end
23135: subl2 r6,r8 # adjust, giving space for n offsets
23136: subl2 $4,r8 # point to a(0)
23137: movl 4*arofs(r10),r7 # offset to word before first item
23138: addl2 $4,r7 # offset to first item
23139: #
23140: # SEPARATE PRE-PROCESSING FOR ARRAYS AND VECTORS DONE.
23141: # TO SIMPLIFY LATER KEY COMPARISONS, REMOVAL OF ANY TRBLK
23142: # TRAP BLOCKS FROM ENTRIES IN KEY ARRAY IS EFFECTED.
23143: #
23144: # (XL) = 1(XS) = POINTER TO KEY ARRAY
23145: # (XS) = POINTER TO SORT ARRAY
23146: # WA = NUMBER OF ITEMS, N (CONVERTED TO BYTES).
23147: # WB = OFFSET TO FIRST ITEM OF ARRAYS.
23148: # WC = OFFSET TO A(0)
23149: #
23150: srt04: cmpl r6,$4*num01 # return if only a single item
23151: bgtru 0f
23152: jmp srt15
23153: 0:
23154: movl r6,srtsn # store number of items (in baus)
23155: movl r8,srtso # store offset to a(0)
23156: movl 4*arlen(r10),r8 # length of array or vec (=vclen)
23157: addl2 r10,r8 # point past end of array or vector
23158: movl r7,srtsf # store offset to first row
23159: addl2 r7,r10 # point to first item in key array
23160: #
23161: # LOOP THROUGH ARRAY
23162: #
23163: srt05: movl (r10),r9 # get an entry
23164: #
23165: # HUNT ALONG TRBLK CHAIN
23166: #
23167: srt06: cmpl (r9),$b$trt # jump out if not trblk
23168: bnequ srt07
23169: movl 4*trval(r9),r9 # get value field
23170: jmp srt06 # loop
23171: #page
23172: #
23173: # SORTA (CONTINUED)
23174: #
23175: # XR IS VALUE FROM END OF CHAIN
23176: #
23177: srt07: movl r9,(r10)+ # store as array entry
23178: cmpl r10,r8 # loop if not done
23179: blssu srt05
23180: movl (sp),r10 # get adrs of sort array
23181: movl srtsf,r9 # initial offset to first key
23182: movl srtst,r7 # get stride
23183: addl2 srtso,r10 # offset to a(0)
23184: addl2 $4,r10 # point to a(1)
23185: movl srtsn,r8 # get n
23186: ashl $-2,r8,r8 # convert from bytes
23187: movl r8,srtnr # store as row count
23188: # loop counter
23189: #
23190: # STORE KEY OFFSETS AT TOP OF SORT ARRAY
23191: #
23192: srt08: movl r9,(r10)+ # store an offset
23193: addl2 r7,r9 # bump offset by stride
23194: sobgtr r8,srt08 # loop through rows
23195: #
23196: # PERFORM THE SORT ON OFFSETS IN SORT ARRAY.
23197: #
23198: # (SRTSN) NUMBER OF ITEMS TO SORT, N (BYTES)
23199: # (SRTSO) OFFSET TO A(0)
23200: #
23201: srt09: movl srtsn,r6 # get n
23202: movl srtnr,r8 # get number of rows
23203: ashl $-1,r8,r8 # i = n / 2 (wc=i, index into array)
23204: moval 0[r8],r8 # convert back to bytes
23205: #
23206: # LOOP TO FORM INITIAL HEAP
23207: #
23208: srt10: jsb sorth # sorth(i,n)
23209: subl2 $4,r8 # i = i - 1
23210: tstl r8 # loop if i gt 0
23211: bnequ srt10
23212: movl r6,r8 # i = n
23213: #
23214: # SORTING LOOP. AT THIS POINT, A(1) IS THE LARGEST
23215: # ITEM, SINCE ALGORITHM INITIALISES IT AS, AND THEN MAINTAI
23216: # IT AS, ROOT OF TREE.
23217: #
23218: srt11: subl2 $4,r8 # i = i - 1 (n - 1 initially)
23219: tstl r8 # jump if done
23220: beqlu srt12
23221: movl (sp),r9 # get sort array address
23222: addl2 srtso,r9 # point to a(0)
23223: movl r9,r10 # a(0) address
23224: addl2 r8,r10 # a(i) address
23225: movl 4*1(r10),r7 # copy a(i+1)
23226: movl 4*1(r9),4*1(r10)# move a(1) to a(i+1)
23227: movl r7,4*1(r9) # complete exchange of a(1), a(i+1)
23228: movl r8,r6 # n = i for sorth
23229: movl $4*num01,r8 # i = 1 for sorth
23230: jsb sorth # sorth(1,n)
23231: movl r6,r8 # restore wc
23232: jmp srt11 # loop
23233: #page
23234: #
23235: # SORTA (CONTINUED)
23236: #
23237: # OFFSETS HAVE BEEN PERMUTED INTO REQUIRED ORDER BY SORT.
23238: # COPY ARRAY ELEMENTS OVER THEM.
23239: #
23240: srt12: movl (sp),r10 # base adrs of key array
23241: movl r10,r8 # copy it
23242: addl2 srtso,r8 # offset of a(0)
23243: addl2 srtsf,r10 # adrs of first row of sort array
23244: movl srtst,r7 # get stride
23245: ashl $-2,r7,r7 # convert to words
23246: #
23247: # COPYING LOOP FOR SUCCESSIVE ITEMS. SORTED OFFSETS ARE
23248: # HELD AT END OF SORT ARRAY.
23249: #
23250: srt13: addl2 $4,r8 # adrs of next of sorted offsets
23251: movl r8,r9 # copy it for access
23252: movl (r9),r9 # get offset
23253: addl2 4*1(sp),r9 # add key array base adrs
23254: movl r7,r6 # get count of words in row
23255: #
23256: # COPY A COMPLETE ROW
23257: #
23258: srt14: movl (r9)+,(r10)+ # move a word
23259: sobgtr r6,srt14 # loop
23260: decl srtnr # decrement row count
23261: tstl srtnr # repeat till all rows done
23262: bnequ srt13
23263: #
23264: # RETURN POINT
23265: #
23266: srt15: movl (sp)+,r9 # pop result array ptr
23267: addl2 $4,sp # pop key array ptr
23268: clrl r$sxl # clear junk
23269: clrl r$sxr # clear junk
23270: jmp *sorta_s # return
23271: #
23272: # ERROR POINT
23273: #
23274: srt16: jmp er_256 # sort/rsort 1st arg not suitable array or table
23275: srt17: jmp er_258 # sort/rsort 2nd arg out of range or non-integer
23276: #enp # end procudure sorta
23277: #page
23278: #
23279: # SORTC -- COMPARE SORT KEYS
23280: #
23281: # COMPARE TWO SORT KEYS GIVEN THEIR OFFSETS. IF
23282: # EQUAL, COMPARE KEY OFFSETS TO GIVE STABLE SORT.
23283: # NOTE THAT IF SRTSR IS NON-ZERO (REQUEST FOR REVERSE
23284: # SORT), THE QUOTED RETURNS ARE INVERTED.
23285: # FOR OBJECTS OF DIFFERING DATATYPES, THE ENTRY POINT
23286: # IDENTIFICATIONS ARE COMPARED.
23287: #
23288: # (XL) BASE ADRS FOR KEYS
23289: # (WA) OFFSET TO KEY 1 ITEM
23290: # (WB) OFFSET TO KEY 2 ITEM
23291: # (SRTSR) ZERO/NON-ZERO FOR SORT/RSORT
23292: # (SRTOF) OFFSET WITHIN ROW TO COMPARANDS
23293: # JSR SORTC CALL TO COMPARE KEYS
23294: # PPM LOC KEY1 LESS THAN KEY2
23295: # NORMAL RETURN, KEY1 GT THAN KEY2
23296: # (XL,XR,WA,WB) DESTROYED
23297: #
23298: sortc: #prc # entry point
23299: movl r6,srts1 # save offset 1
23300: movl r7,srts2 # save offset 2
23301: movl r8,srtsc # save wc
23302: addl2 srtof,r10 # add offset to comparand field
23303: movl r10,r9 # copy base + offset
23304: addl2 r6,r10 # add key1 offset
23305: addl2 r7,r9 # add key2 offset
23306: movl (r10),r10 # get key1
23307: movl (r9),r9 # get key2
23308: cmpl srtdf,$nulls # jump if datatype field name used
23309: beqlu 0f
23310: jmp src11
23311: 0:
23312: #page
23313: #
23314: # SORTC (CONTINUED)
23315: #
23316: # MERGE AFTER DEALING WITH FIELD NAME. TRY FOR STRINGS.
23317: #
23318: src01: movl (r10),r8 # get type code
23319: cmpl r8,(r9) # skip if not same datatype
23320: bnequ src02
23321: cmpl r8,$b$scl # jump if both strings
23322: beqlu src09
23323: #
23324: # NOW TRY FOR NUMERIC
23325: #
23326: src02: movl r10,r$sxl # keep arg1
23327: movl r9,r$sxr # keep arg2
23328: movl r10,-(sp) # stack
23329: movl r9,-(sp) # args
23330: jsb acomp # compare objects
23331: .long src10 # not numeric
23332: .long src10 # not numeric
23333: .long src03 # key1 less
23334: .long src08 # keys equal
23335: .long src05 # key1 greater
23336: #
23337: # RETURN IF KEY1 SMALLER (SORT), GREATER (RSORT)
23338: #
23339: src03: tstl srtsr # jump if rsort
23340: bnequ src06
23341: #
23342: src04: movl srtsc,r8 # restore wc
23343: movl (sp)+,r11 # return
23344: jmp *(r11)+
23345: #
23346: # RETURN IF KEY1 GREATER (SORT), SMALLER (RSORT)
23347: #
23348: src05: tstl srtsr # jump if rsort
23349: bnequ src04
23350: #
23351: src06: movl srtsc,r8 # restore wc
23352: addl2 $4*1,(sp) # return
23353: rsb
23354: #
23355: # KEYS ARE OF SAME DATATYPE
23356: #
23357: src07: cmpl r10,r9 # item first created is less
23358: blssu src03
23359: cmpl r10,r9 # addresses rise in order of creation
23360: bgtru src05
23361: #
23362: # DROP THROUGH OR MERGE FOR IDENTICAL OR EQUAL OBJECTS
23363: #
23364: src08: cmpl srts1,srts2 # test offsets or key addrss instead
23365: blssu src04
23366: jmp src06 # offset 1 greater
23367: #page
23368: #
23369: # SORTC (CONTINUED)
23370: #
23371: # STRINGS
23372: #
23373: src09: movl r10,-(sp) # stack
23374: movl r9,-(sp) # args
23375: jsb lcomp # compare objects
23376: .long invalid$ # cant
23377: .long invalid$ # fail
23378: .long src03 # key1 less
23379: .long src08 # keys equal
23380: .long src05 # key1 greater
23381: #
23382: # ARITHMETIC COMPARISON FAILED - RECOVER ARGS
23383: #
23384: src10: movl r$sxl,r10 # get arg1
23385: movl r$sxr,r9 # get arg2
23386: movl (r10),r8 # get type of key1
23387: cmpl r8,(r9) # jump if keys of same type
23388: beqlu src07
23389: movl r8,r10 # get block type word
23390: movl (r9),r9 # get block type word
23391: movzwl -2(r10),r10 # entry point id for key1
23392: movzwl -2(r9),r9 # entry point id for key2
23393: cmpl r10,r9 # jump if key1 gt key2
23394: bgtru src05
23395: jmp src03 # key1 lt key2
23396: #
23397: # DATATYPE FIELD NAME USED
23398: #
23399: src11: jsb sortf # call routine to find field 1
23400: movl r10,-(sp) # stack item pointer
23401: movl r9,r10 # get key2
23402: jsb sortf # find field 2
23403: movl r10,r9 # place as key2
23404: movl (sp)+,r10 # recover key1
23405: jmp src01 # merge
23406: #enp # procedure sortc
23407: #page
23408: #
23409: # SORTF -- FIND FIELD FOR SORTC
23410: #
23411: # ROUTINE USED BY SORTC TO OBTAIN ITEM CORRESPONDING
23412: # TO A GIVEN FIELD NAME, IF THIS EXISTS, IN A PROGRAMMER
23413: # DEFINED OBJECT PASSED AS ARGUMENT.
23414: # IF SUCH A MATCH OCCURS, RECORD IS KEPT OF DATATYPE
23415: # NAME, FIELD NAME AND OFFSET TO FIELD IN ORDER TO
23416: # SHORT-CIRCUIT LATER SEARCHES ON SAME TYPE. NOTE THAT
23417: # DFBLKS ARE STORED IN STATIC AND HENCE CANNOT BE MOVED.
23418: #
23419: # (SRTDF) VRBLK POINTER OF FIELD NAME
23420: # (XL) POSSIBLE PDBLK POINTER
23421: # JSR SORTF CALL TO SEARCH FOR FIELD NAME
23422: # (XL) ITEM FOUND OR ORIGINAL PDBLK PTR
23423: # (WC) DESTROYED
23424: #
23425: sortf: #prc # entry point
23426: cmpl (r10),$b$pdt # return if not pdblk
23427: bnequ srtf3
23428: movl r9,-(sp) # keep xr
23429: movl srtfd,r9 # get possible former dfblk ptr
23430: tstl r9 # jump if not
23431: beqlu srtf4
23432: cmpl r9,4*pddfp(r10) # jump if not right datatype
23433: bnequ srtf4
23434: cmpl srtdf,srtff # jump if not right field name
23435: bnequ srtf4
23436: addl2 srtfo,r10 # add offset to required field
23437: #
23438: # HERE WITH XL POINTING TO FOUND FIELD
23439: #
23440: srtf1: movl (r10),r10 # get item from field
23441: #
23442: # RETURN POINT
23443: #
23444: srtf2: movl (sp)+,r9 # restore xr
23445: #
23446: srtf3: rsb # return
23447: #page
23448: #
23449: # SORTF (CONTINUED)
23450: #
23451: # CONDUCT A SEARCH
23452: #
23453: srtf4: movl r10,r9 # copy original pointer
23454: movl 4*pddfp(r9),r9 # point to dfblk
23455: movl r9,srtfd # keep a copy
23456: movl 4*fargs(r9),r8 # get number of fields
23457: moval 0[r8],r8 # convert to bytes
23458: addl2 4*dflen(r9),r9 # point past last field
23459: #
23460: # LOOP TO FIND NAME IN PDFBLK
23461: #
23462: srtf5: subl2 $4,r8 # count down
23463: subl2 $4,r9 # point in front
23464: cmpl (r9),srtdf # skip out if found
23465: beqlu srtf6
23466: tstl r8 # loop
23467: bnequ srtf5
23468: jmp srtf2 # return - not found
23469: #
23470: # FOUND
23471: #
23472: srtf6: movl (r9),srtff # keep field name ptr
23473: addl2 $4*pdfld,r8 # add offset to first field
23474: movl r8,srtfo # store as field offset
23475: addl2 r8,r10 # point to field
23476: jmp srtf1 # return
23477: #enp # procedure sortf
23478: #page
23479: #
23480: # SORTH -- HEAP ROUTINE FOR SORTA
23481: #
23482: # THIS ROUTINE CONSTRUCTS A HEAP FROM ELEMENTS OF ARRAY, A.
23483: # IN THIS APPLICATION, THE ELEMENTS ARE OFFSETS TO KEYS IN
23484: # A KEY ARRAY.
23485: #
23486: # (XS) POINTER TO SORT ARRAY BASE
23487: # 1(XS) POINTER TO KEY ARRAY BASE
23488: # (WA) MAX ARRAY INDEX, N (IN BYTES)
23489: # (WC) OFFSET J IN A TO ROOT (IN *1 TO *N)
23490: # JSR SORTH CALL SORTH(J,N) TO MAKE HEAP
23491: # (XL,XR,WB) DESTROYED
23492: #
23493: .data 1
23494: sorth_s: .long 0
23495: .text 0
23496: sorth: movl (sp)+,sorth_s # entry point
23497: movl r6,srtsn # save n
23498: movl r8,srtwc # keep wc
23499: movl (sp),r10 # sort array base adrs
23500: addl2 srtso,r10 # add offset to a(0)
23501: addl2 r8,r10 # point to a(j)
23502: movl (r10),srtrt # get offset to root
23503: addl2 r8,r8 # double j - cant exceed n
23504: #
23505: # LOOP TO MOVE DOWN TREE USING DOUBLED INDEX J
23506: #
23507: srh01: cmpl r8,srtsn # done if j gt n
23508: bgtru srh03
23509: cmpl r8,srtsn # skip if j equals n
23510: beqlu srh02
23511: movl (sp),r9 # sort array base adrs
23512: movl 4*1(sp),r10 # key array base adrs
23513: addl2 srtso,r9 # point to a(0)
23514: addl2 r8,r9 # adrs of a(j)
23515: movl 4*1(r9),r6 # get a(j+1)
23516: movl (r9),r7 # get a(j)
23517: #
23518: # COMPARE SONS. (WA) RIGHT SON, (WB) LEFT SON
23519: #
23520: jsb sortc # compare keys - lt(a(j+1),a(j))
23521: .long srh02 # a(j+1) lt a(j)
23522: addl2 $4,r8 # point to greater son, a(j+1)
23523: #page
23524: #
23525: # SORTH (CONTINUED)
23526: #
23527: # COMPARE ROOT WITH GREATER SON
23528: #
23529: srh02: movl 4*1(sp),r10 # key array base adrs
23530: movl (sp),r9 # get sort array address
23531: addl2 srtso,r9 # adrs of a(0)
23532: movl r9,r7 # copy this adrs
23533: addl2 r8,r9 # adrs of greater son, a(j)
23534: movl (r9),r6 # get a(j)
23535: movl r7,r9 # point back to a(0)
23536: movl srtrt,r7 # get root
23537: jsb sortc # compare them - lt(a(j),root)
23538: .long srh03 # father exceeds sons - done
23539: movl (sp),r9 # get sort array adrs
23540: addl2 srtso,r9 # point to a(0)
23541: movl r9,r10 # copy it
23542: movl r8,r6 # copy j
23543: ashl $-2,r8,r8 # convert to words
23544: ashl $-1,r8,r8 # get j/2
23545: moval 0[r8],r8 # convert back to bytes
23546: addl2 r6,r10 # point to a(j)
23547: addl2 r8,r9 # adrs of a(j/2)
23548: movl (r10),(r9) # a(j/2) = a(j)
23549: movl r6,r8 # recover j
23550: addl2 r8,r8 # j = j*2. done if too big
23551: bvc 0f
23552: jmp srh03
23553: 0:
23554: jmp srh01 # loop
23555: #
23556: # FINISH BY COPYING ROOT OFFSET BACK INTO ARRAY
23557: #
23558: srh03: ashl $-2,r8,r8 # convert to words
23559: ashl $-1,r8,r8 # j = j/2
23560: moval 0[r8],r8 # convert back to bytes
23561: movl (sp),r9 # sort array adrs
23562: addl2 srtso,r9 # adrs of a(0)
23563: addl2 r8,r9 # adrs of a(j/2)
23564: movl srtrt,(r9) # a(j/2) = root
23565: movl srtsn,r6 # restore wa
23566: movl srtwc,r8 # restore wc
23567: jmp *sorth_s # return
23568: #enp # end procedure sorth
23569: #page
23570: #page
23571: #
23572: # TFIND -- LOCATE TABLE ELEMENT
23573: #
23574: # (XR) SUBSCRIPT VALUE FOR ELEMENT
23575: # (XL) POINTER TO TABLE
23576: # (WB) ZERO BY VALUE, NON-ZERO BY NAME
23577: # JSR TFIND CALL TO LOCATE ELEMENT
23578: # PPM LOC TRANSFER LOCATION IF ACCESS FAILS
23579: # (XR) ELEMENT VALUE (IF BY VALUE)
23580: # (XR) DESTROYED (IF BY NAME)
23581: # (XL,WA) TEBLK NAME (IF BY NAME)
23582: # (XL,WA) DESTROYED (IF BY VALUE)
23583: # (WC,RA) DESTROYED
23584: #
23585: # NOTE THAT IF A CALL BY VALUE SPECIFIES A NON-EXISTENT
23586: # SUBSCRIPT, NULL IS RETURNED WITHOUT BUILDING A NEW TEBLK.
23587: #
23588: tfind: #prc # entry point
23589: movl r7,-(sp) # save name/value indicator
23590: movl r9,-(sp) # save subscript value
23591: movl r10,-(sp) # save table pointer
23592: movl 4*tblen(r10),r6 # load length of tbblk
23593: ashl $-2,r6,r6 # convert to word count
23594: subl2 $tbbuk,r6 # get number of buckets
23595: movl r6,r5 # convert to integer value
23596: movl r5,tfnsi # save for later
23597: movl (r9),r10 # load first word of subscript
23598: movzwl -2(r10),r10 # load block entry id (bl$xx)
23599: casel r10,$0,$bl$$d # switch on block type
23600: 5:
23601: .word tfn00-5b
23602: .word tfn00-5b
23603: .word tfn00-5b
23604: .word tfn00-5b
23605: .word tfn02-5b # jump if integer
23606: .word tfn04-5b # jump if name
23607: .word tfn03-5b # jump if pattern
23608: .word tfn03-5b # jump if pattern
23609: .word tfn03-5b # jump if pattern
23610: .word tfn02-5b # real
23611: .word tfn05-5b # jump if string
23612: .word tfn00-5b
23613: .word tfn00-5b
23614: .word tfn00-5b
23615: .word tfn00-5b
23616: .word tfn00-5b
23617: .word tfn00-5b
23618: #esw # end switch on block type
23619: #
23620: # HERE FOR BLOCKS FOR WHICH WE USE THE SECOND WORD OF THE
23621: # BLOCK AS THE HASH SOURCE (SEE BLOCK FORMATS FOR DETAILS).
23622: #
23623: tfn00: movl 4*1(r9),r6 # load second word
23624: #
23625: # MERGE HERE WITH ONE WORD HASH SOURCE IN WA
23626: #
23627: tfn01: movl r6,r5 # convert to integer
23628: jmp tfn06 # jump to merge
23629: #page
23630: #
23631: # TFIND (CONTINUED)
23632: #
23633: # HERE FOR INTEGER OR REAL
23634: #
23635: tfn02: movl 4*1(r9),r5 # load value as hash source
23636: tstl r5 # ok if positive or zero
23637: bgeq tfn06
23638: mnegl r5,r5 # make positive
23639: bvs tfn06
23640: jmp tfn06 # merge
23641: #
23642: # FOR PATTERN, USE FIRST WORD (PCODE) AS SOURCE
23643: #
23644: tfn03: movl (r9),r6 # load first word as hash source
23645: jmp tfn01 # merge back
23646: #
23647: # FOR NAME, USE OFFSET AS HASH SOURCE
23648: #
23649: tfn04: movl 4*nmofs(r9),r6 # load offset as hash source
23650: jmp tfn01 # merge back
23651: #
23652: # HERE FOR STRING
23653: #
23654: tfn05: jsb hashs # call routine to compute hash
23655: #
23656: # MERGE HERE WITH HASH SOURCE IN (IA)
23657: #
23658: tfn06: ashq $-32,r4,r4 # compute hash index by remaindering
23659: ediv tfnsi,r4,r11,r5
23660: movl r5,r8 # get as one word integer
23661: moval 0[r8],r8 # convert to byte offset
23662: movl (sp),r10 # get table ptr again
23663: addl2 r8,r10 # point to proper bucket
23664: movl 4*tbbuk(r10),r9 # load first teblk pointer
23665: cmpl r9,(sp) # jump if no teblks on chain
23666: beqlu tfn10
23667: #
23668: # LOOP THROUGH TEBLKS ON HASH CHAIN
23669: #
23670: tfn07: movl r9,r7 # save teblk pointer
23671: movl 4*tesub(r9),r9 # load subscript value
23672: movl 4*1(sp),r10 # load input argument subscript val
23673: jsb ident # compare them
23674: .long tfn08 # jump if equal (ident)
23675: #
23676: # HERE IF NO MATCH WITH THAT TEBLK
23677: #
23678: movl r7,r10 # restore teblk pointer
23679: movl 4*tenxt(r10),r9 # point to next teblk on chain
23680: cmpl r9,(sp) # jump if there is one
23681: bnequ tfn07
23682: #
23683: # HERE IF NO MATCH WITH ANY TEBLK ON CHAIN
23684: #
23685: movl $4*tenxt,r8 # set offset to link field (xl base)
23686: jmp tfn11 # jump to merge
23687: #page
23688: #
23689: # TFIND (CONTINUED)
23690: #
23691: # HERE WE HAVE FOUND A MATCHING ELEMENT
23692: #
23693: tfn08: movl r7,r10 # restore teblk pointer
23694: movl $4*teval,r6 # set teblk name offset
23695: movl 4*2(sp),r7 # restore name/value indicator
23696: tstl r7 # jump if called by name
23697: bnequ tfn09
23698: jsb acess # else get value
23699: .long tfn12 # jump if reference fails
23700: clrl r7 # restore name/value indicator
23701: #
23702: # COMMON EXIT FOR ENTRY FOUND
23703: #
23704: tfn09: addl2 $4*num03,sp # pop stack entries
23705: addl2 $4*1,(sp) # return to tfind caller
23706: rsb
23707: #
23708: # HERE IF NO TEBLKS ON THE HASH CHAIN
23709: #
23710: tfn10: addl2 $4*tbbuk,r8 # get offset to bucket ptr
23711: movl (sp),r10 # set tbblk ptr as base
23712: #
23713: # MERGE HERE WITH (XL,WC) BASE,OFFSET OF FINAL LINK
23714: #
23715: tfn11: movl (sp),r9 # tbblk pointer
23716: movl 4*tbinv(r9),r9 # load default value in case
23717: movl 4*2(sp),r7 # load name/value indicator
23718: tstl r7 # exit with default if value call
23719: beqlu tfn09
23720: #
23721: # HERE WE MUST BUILD A NEW TEBLK
23722: #
23723: movl $4*tesi$,r6 # set size of teblk
23724: jsb alloc # allocate teblk
23725: addl2 r8,r10 # point to hash link
23726: movl r9,(r10) # link new teblk at end of chain
23727: movl $b$tet,(r9) # store type word
23728: movl $nulls,4*teval(r9) # set null as initial value
23729: movl (sp)+,4*tenxt(r9)# set tbblk ptr to mark end of chain
23730: movl (sp)+,4*tesub(r9)# store subscript value
23731: addl2 $4,sp # pop past name/value indicator
23732: movl r9,r10 # copy teblk pointer (name base)
23733: movl $4*teval,r6 # set offset
23734: addl2 $4*1,(sp) # return to caller with new teblk
23735: rsb
23736: #
23737: # ACESS FAIL RETURN
23738: #
23739: tfn12: movl (sp)+,r11 # alternative return
23740: jmp *(r11)+
23741: #enp # end procedure tfind
23742: #page
23743: #
23744: # TRACE -- SET/RESET A TRACE ASSOCIATION
23745: #
23746: # THIS PROCEDURE IS SHARED BY TRACE AND STOPTR TO
23747: # EITHER INITIATE OR STOP A TRACE RESPECTIVELY.
23748: #
23749: # (XL) TRBLK PTR (TRACE) OR ZERO (STOPTR)
23750: # 1(XS) FIRST ARGUMENT (NAME)
23751: # 0(XS) SECOND ARGUMENT (TRACE TYPE)
23752: # JSR TRACE CALL TO SET/RESET TRACE
23753: # PPM LOC TRANSFER LOC IF 1ST ARG IS BAD NAME
23754: # PPM LOC TRANSFER LOC IF 2ND ARG IS BAD TYPE
23755: # (XS) POPPED
23756: # (XL,XR,WA,WB,WC,IA) DESTROYED
23757: #
23758: .data 1
23759: trace_s: .long 0
23760: .text 0
23761: trace: movl (sp)+,trace_s # entry point
23762: jsb gtstg # get trace type string
23763: .long trc15 # jump if not string
23764: movab cfp$f(r9),r9 # else point to string
23765: movzbl (r9),r6 # load first character
23766: bicl2 $ch$bl,r6 # fold to upper case
23767: movl (sp),r9 # load name argument
23768: movl r10,(sp) # stack trblk ptr or zero
23769: movl $trtac,r8 # set trtyp for access trace
23770: cmpl r6,$ch$la # jump if a (access)
23771: bnequ 0f
23772: jmp trc10
23773: 0:
23774: movl $trtvl,r8 # set trtyp for value trace
23775: cmpl r6,$ch$lv # jump if v (value)
23776: bnequ 0f
23777: jmp trc10
23778: 0:
23779: tstl r6 # jump if blank (value)
23780: bnequ 0f
23781: jmp trc10
23782: 0:
23783: #
23784: # HERE FOR L,K,F,C,R
23785: #
23786: cmpl r6,$ch$lf # jump if f (function)
23787: beqlu trc01
23788: cmpl r6,$ch$lr # jump if r (return)
23789: beqlu trc01
23790: cmpl r6,$ch$ll # jump if l (label)
23791: beqlu trc03
23792: cmpl r6,$ch$lk # jump if k (keyword)
23793: bnequ 0f
23794: jmp trc06
23795: 0:
23796: cmpl r6,$ch$lc # else error if not c (call)
23797: beqlu 0f
23798: jmp trc15
23799: 0:
23800: #
23801: # HERE FOR F,C,R
23802: #
23803: trc01: jsb gtnvr # point to vrblk for name
23804: .long trc16 # jump if bad name
23805: addl2 $4,sp # pop stack
23806: movl 4*vrfnc(r9),r9 # point to function block
23807: cmpl (r9),$b$pfc # error if not program function
23808: beqlu 0f
23809: jmp trc17
23810: 0:
23811: cmpl r6,$ch$lr # jump if r (return)
23812: beqlu trc02
23813: #page
23814: #
23815: # TRACE (CONTINUED)
23816: #
23817: # HERE FOR F,C TO SET/RESET CALL TRACE
23818: #
23819: movl r10,4*pfctr(r9) # set/reset call trace
23820: cmpl r6,$ch$lc # exit with null if c (call)
23821: bnequ 0f
23822: jmp exnul
23823: 0:
23824: #
23825: # HERE FOR F,R TO SET/RESET RETURN TRACE
23826: #
23827: trc02: movl r10,4*pfrtr(r9) # set/reset return trace
23828: addl3 $4*2,trace_s,r11 # return
23829: jmp (r11)
23830: #
23831: # HERE FOR L TO SET/RESET LABEL TRACE
23832: #
23833: trc03: jsb gtnvr # point to vrblk
23834: .long trc16 # jump if bad name
23835: movl 4*vrlbl(r9),r10 # load label pointer
23836: cmpl (r10),$b$trt # jump if no old trace
23837: bnequ trc04
23838: movl 4*trlbl(r10),r10# else delete old trace association
23839: #
23840: # HERE WITH OLD LABEL TRACE ASSOCIATION DELETED
23841: #
23842: trc04: cmpl r10,$stndl # error if undefined label
23843: bnequ 0f
23844: jmp trc16
23845: 0:
23846: movl (sp)+,r7 # get trblk ptr again
23847: tstl r7 # jump if stoptr case
23848: beqlu trc05
23849: movl r7,4*vrlbl(r9) # else set new trblk pointer
23850: movl $b$vrt,4*vrtra(r9) # set label trace routine address
23851: movl r7,r9 # copy trblk pointer
23852: movl r10,4*trlbl(r9) # store real label in trblk
23853: addl3 $4*2,trace_s,r11 # return
23854: jmp (r11)
23855: #
23856: # HERE FOR STOPTR CASE FOR LABEL
23857: #
23858: trc05: movl r10,4*vrlbl(r9) # store label ptr back in vrblk
23859: movl $b$vrg,4*vrtra(r9) # store normal transfer address
23860: addl3 $4*2,trace_s,r11 # return
23861: jmp (r11)
23862: #page
23863: #
23864: # TRACE (CONTINUED)
23865: #
23866: # HERE FOR K (KEYWORD)
23867: #
23868: trc06: jsb gtnvr # point to vrblk
23869: .long trc16 # error if not natural var
23870: tstl 4*vrlen(r9) # error if not system var
23871: beqlu 0f
23872: jmp trc16
23873: 0:
23874: addl2 $4,sp # pop stack
23875: tstl r10 # jump if stoptr case
23876: beqlu trc07
23877: movl r9,4*trkvr(r10) # store vrblk ptr in trblk for ktrex
23878: #
23879: # MERGE HERE WITH TRBLK SET UP IN WB (OR ZERO)
23880: #
23881: trc07: movl 4*vrsvp(r9),r9 # point to svblk
23882: cmpl r9,$v$ert # jump if errtype
23883: beqlu trc08
23884: cmpl r9,$v$stc # jump if stcount
23885: beqlu trc09
23886: cmpl r9,$v$fnc # else error if not fnclevel
23887: beqlu 0f
23888: jmp trc17
23889: 0:
23890: #
23891: # FNCLEVEL
23892: #
23893: movl r10,r$fnc # set/reset fnclevel trace
23894: addl3 $4*2,trace_s,r11 # return
23895: jmp (r11)
23896: #
23897: # ERRTYPE
23898: #
23899: trc08: movl r10,r$ert # set/reset errtype trace
23900: addl3 $4*2,trace_s,r11 # return
23901: jmp (r11)
23902: #
23903: # STCOUNT
23904: #
23905: trc09: movl r10,r$stc # set/reset stcount trace
23906: addl3 $4*2,trace_s,r11 # return
23907: jmp (r11)
23908: #page
23909: #
23910: # TRACE (CONTINUED)
23911: #
23912: # A,V MERGE HERE WITH TRTYP VALUE IN WC
23913: #
23914: trc10: jsb gtvar # locate variable
23915: .long trc16 # error if not appropriate name
23916: movl (sp)+,r7 # get new trblk ptr again
23917: addl2 r10,r6 # point to variable location
23918: movl r6,r9 # copy variable pointer
23919: #
23920: # LOOP TO SEARCH TRBLK CHAIN
23921: #
23922: trc11: movl (r9),r10 # point to next entry
23923: cmpl (r10),$b$trt # jump if not trblk
23924: bnequ trc13
23925: cmpl r8,4*trtyp(r10) # jump if too far out on chain
23926: blssu trc13
23927: cmpl r8,4*trtyp(r10) # jump if this matches our type
23928: beqlu trc12
23929: addl2 $4*trnxt,r10 # else point to link field
23930: movl r10,r9 # copy pointer
23931: jmp trc11 # and loop back
23932: #
23933: # HERE TO DELETE AN OLD TRBLK OF THE TYPE WE WERE GIVEN
23934: #
23935: trc12: movl 4*trnxt(r10),r10# get ptr to next block or value
23936: movl r10,(r9) # store to delete this trblk
23937: #
23938: # HERE AFTER DELETING ANY OLD ASSOCIATION OF THIS TYPE
23939: #
23940: trc13: tstl r7 # jump if stoptr case
23941: beqlu trc14
23942: movl r7,(r9) # else link new trblk in
23943: movl r7,r9 # copy trblk pointer
23944: movl r10,4*trnxt(r9) # store forward pointer
23945: movl r8,4*trtyp(r9) # store appropriate trap type code
23946: #
23947: # HERE TO MAKE SURE VRGET,VRSTO ARE SET PROPERLY
23948: #
23949: trc14: movl r6,r9 # recall possible vrblk pointer
23950: subl2 $4*vrval,r9 # point back to vrblk
23951: jsb setvr # set fields if vrblk
23952: addl3 $4*2,trace_s,r11 # return
23953: jmp (r11)
23954: #
23955: # HERE FOR BAD TRACE TYPE
23956: #
23957: trc15: addl3 $4*1,trace_s,r11 # take bad trace type error exit
23958: jmp *(r11)+
23959: #
23960: # POP STACK BEFORE FAILING
23961: #
23962: trc16: addl2 $4,sp # pop stack
23963: #
23964: # HERE FOR BAD NAME ARGUMENT
23965: #
23966: trc17: movl trace_s,r11 # take bad name error exit
23967: jmp *(r11)+
23968: #enp # end procedure trace
23969: #page
23970: #
23971: # TRBLD -- BUILD TRBLK
23972: #
23973: # TRBLK IS USED BY THE INPUT, OUTPUT AND TRACE FUNCTIONS
23974: # TO CONSTRUCT A TRBLK (TRAP BLOCK)
23975: #
23976: # (XR) TRTAG OR TRTER
23977: # (XL) TRFNC OR TRFPT
23978: # (WB) TRTYP
23979: # JSR TRBLD CALL TO BUILD TRBLK
23980: # (XR) POINTER TO TRBLK
23981: # (WA) DESTROYED
23982: #
23983: trbld: #prc # entry point
23984: movl r9,-(sp) # stack trtag (or trfnm)
23985: movl $4*trsi$,r6 # set size of trblk
23986: jsb alloc # allocate trblk
23987: movl $b$trt,(r9) # store first word
23988: movl r10,4*trfnc(r9) # store trfnc (or trfpt)
23989: movl (sp)+,4*trtag(r9)# store trtag (or trfnm)
23990: movl r7,4*trtyp(r9) # store type
23991: movl $nulls,4*trval(r9) # for now, a null value
23992: rsb # return to caller
23993: #enp # end procedure trbld
23994: #page
23995: #
23996: # TRIMR -- TRIM TRAILING BLANKS
23997: #
23998: # TRIMR IS PASSED A POINTER TO AN SCBLK WHICH MUST BE THE
23999: # LAST BLOCK IN DYNAMIC STORAGE. TRAILING BLANKS ARE
24000: # TRIMMED OFF AND THE DYNAMIC STORAGE POINTER RESET TO
24001: # THE END OF THE (POSSIBLY) SHORTENED BLOCK.
24002: #
24003: # (WB) NON-ZERO TO TRIM TRAILING BLANKS
24004: # (XR) POINTER TO STRING TO TRIM
24005: # JSR TRIMR CALL TO TRIM STRING
24006: # (XR) POINTER TO TRIMMED STRING
24007: # (XL,WA,WB,WC) DESTROYED
24008: #
24009: # THE CALL WITH WB ZERO STILL PERFORMS THE END ZERO PAD
24010: # AND DNAMP READJUSTMENT. IT IS USED FROM ACESS IF KVTRM=0.
24011: #
24012: trimr: #prc # entry point
24013: movl r9,r10 # copy string pointer
24014: movl 4*sclen(r9),r6 # load string length
24015: tstl r6 # jump if null input
24016: beqlu trim2
24017: movab cfp$f(r10)[r6],r10 # else point past last character
24018: tstl r7 # jump if no trim
24019: beqlu trim3
24020: movl $ch$bl,r8 # load blank character
24021: #
24022: # LOOP THROUGH CHARACTERS FROM RIGHT TO LEFT
24023: #
24024: trim0: movzbl -(r10),r7 # load next character
24025: cmpl r7,$ch$ht # jump if horizontal tab
24026: beqlu trim1
24027: cmpl r7,r8 # jump if non-blank found
24028: bnequ trim3
24029: trim1: decl r6 # else decrement character count
24030: tstl r6 # loop back if more to check
24031: bnequ trim0
24032: #
24033: # HERE IF RESULT IS NULL (NULL OR ALL-BLANK INPUT)
24034: #
24035: trim2: movl r9,dnamp # wipe out input string block
24036: movl $nulls,r9 # load null result
24037: jmp trim5 # merge to exit
24038: #page
24039: #
24040: # TRIMR (CONTINUED)
24041: #
24042: # HERE WITH NON-BLANK FOUND (MERGE FOR NO TRIM)
24043: #
24044: trim3: movl r6,4*sclen(r9) # set new length
24045: movl r9,r10 # copy string pointer
24046: movab cfp$f(r10)[r6],r10 # ready for storing blanks
24047: movab 3+(4*schar)(r6),r6 # get length of block in bytes
24048: bicl2 $3,r6
24049: addl2 r9,r6 # point past new block
24050: movl r6,dnamp # set new top of storage pointer
24051: movl $cfp$c,r6 # get count of chars in word
24052: clrl r8 # set blank char
24053: #
24054: # LOOP TO ZERO PAD LAST WORD OF CHARACTERS
24055: #
24056: trim4: movb r8,(r10)+ # store zero character
24057: sobgtr r6,trim4 # loop back till all stored
24058: #csc r10 # complete store characters
24059: #
24060: # COMMON EXIT POINT
24061: #
24062: trim5: clrl r10 # clear garbage xl pointer
24063: rsb # return to caller
24064: #enp # end procedure trimr
24065: #page
24066: #
24067: # TRXEQ -- EXECUTE FUNCTION TYPE TRACE
24068: #
24069: # TRXEQ IS USED TO EXECUTE A TRACE WHEN A FOURTH ARGUMENT
24070: # HAS BEEN SUPPLIED. TRACE HAS ALREADY BEEN DECREMENTED.
24071: #
24072: # (XR) POINTER TO TRBLK
24073: # (XL,WA) NAME BASE,OFFSET FOR VARIABLE
24074: # JSR TRXEQ CALL TO EXECUTE TRACE
24075: # (WB,WC,RA) DESTROYED
24076: #
24077: # THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING
24078: # CONTROL TO THE TRACE FUNCTION USING THE CFUNC ROUTINE.
24079: #
24080: # TRXEQ RETURN POINT WORD(S)
24081: # SAVED VALUE OF TRACE KEYWORD
24082: # TRBLK POINTER
24083: # NAME BASE
24084: # NAME OFFSET
24085: # SAVED VALUE OF R$COD
24086: # SAVED CODE PTR (-R$COD)
24087: # SAVED VALUE OF FLPTR
24088: # FLPTR --------------- ZERO (DUMMY FAIL OFFSET)
24089: # NMBLK FOR VARIABLE NAME
24090: # XS ------------------ TRACE TAG
24091: #
24092: # R$COD AND THE CODE PTR ARE SET TO DUMMY VALUES WHICH
24093: # CAUSE CONTROL TO RETURN TO THE TRXEQ PROCEDURE ON SUCCESS
24094: # OR FAILURE (TRXEQ IGNORES A FAILURE CONDITION).
24095: #
24096: trxeq: #prc # entry point (recursive)
24097: movl r$cod,r8 # load code block pointer
24098: movl r3,r7 # get current code pointer
24099: subl2 r8,r7 # make code pointer into offset
24100: movl kvtra,-(sp) # stack trace keyword value
24101: movl r9,-(sp) # stack trblk pointer
24102: movl r10,-(sp) # stack name base
24103: movl r6,-(sp) # stack name offset
24104: movl r8,-(sp) # stack code block pointer
24105: movl r7,-(sp) # stack code pointer offset
24106: movl flptr,-(sp) # stack old failure pointer
24107: clrl -(sp) # set dummy fail offset
24108: movl sp,flptr # set new failure pointer
24109: clrl kvtra # reset trace keyword to zero
24110: movl $trxdc,r8 # load new (dummy) code blk pointer
24111: movl r8,r$cod # set as code block pointer
24112: movl r8,r3 # and new code pointer
24113: #page
24114: #
24115: # TRXEQ (CONTINUED)
24116: #
24117: # NOW PREPARE ARGUMENTS FOR FUNCTION
24118: #
24119: movl r6,r7 # save name offset
24120: movl $4*nmsi$,r6 # load nmblk size
24121: jsb alloc # allocate space for nmblk
24122: movl $b$nml,(r9) # set type word
24123: movl r10,4*nmbas(r9) # store name base
24124: movl r7,4*nmofs(r9) # store name offset
24125: movl 4*6(sp),r10 # reload pointer to trblk
24126: movl r9,-(sp) # stack nmblk pointer (1st argument)
24127: movl 4*trtag(r10),-(sp) # stack trace tag (2nd argument)
24128: movl 4*trfnc(r10),r10# load trace function pointer
24129: movl $num02,r6 # set number of arguments to two
24130: jmp cfunc # jump to call function
24131: #
24132: # SEE O$TXR FOR DETAILS OF RETURN TO THIS POINT
24133: #
24134: trxq1: movl flptr,sp # point back to our stack entries
24135: addl2 $4,sp # pop off garbage fail offset
24136: movl (sp)+,flptr # restore old failure pointer
24137: movl (sp)+,r7 # reload code offset
24138: movl (sp)+,r8 # load old code base pointer
24139: movl r8,r9 # copy cdblk pointer
24140: movl 4*cdstm(r9),kvstn# restore stmnt no
24141: movl (sp)+,r6 # reload name offset
24142: movl (sp)+,r10 # reload name base
24143: movl (sp)+,r9 # reload trblk pointer
24144: movl (sp)+,kvtra # restore trace keyword value
24145: addl2 r8,r7 # recompute absolute code pointer
24146: movl r7,r3 # restore code pointer
24147: movl r8,r$cod # and code block pointer
24148: rsb # return to trxeq caller
24149: #enp # end procedure trxeq
24150: #page
24151: #
24152: # XSCAN -- EXECUTION FUNCTION ARGUMENT SCAN
24153: #
24154: # XSCAN SCANS OUT ONE TOKEN IN A PROTOTYPE ARGUMENT IN
24155: # ARRAY,CLEAR,DATA,DEFINE,LOAD FUNCTION CALLS. XSCAN
24156: # CALLS MUST BE PRECEDED BY A CALL TO THE INITIALIZATION
24157: # PROCEDURE XSCNI. THE FOLLOWING VARIABLES ARE USED.
24158: #
24159: # R$XSC POINTER TO SCBLK FOR FUNCTION ARG
24160: # XSOFS OFFSET (NUM CHARS SCANNED SO FAR)
24161: #
24162: # (WC) DELIMITER ONE (CH$XX)
24163: # (XL) DELIMITER TWO (CH$XX)
24164: # JSR XSCAN CALL TO SCAN NEXT ITEM
24165: # (XR) POINTER TO SCBLK FOR TOKEN SCANNED
24166: # (WA) COMPLETION CODE (SEE BELOW)
24167: # (WC,XL) DESTROYED
24168: #
24169: # THE SCAN STARTS FROM THE CURRENT POSITION AND CONTINUES
24170: # UNTIL ONE OF THE FOLLOWING THREE CONDITIONS OCCURS.
24171: #
24172: # 1) DELIMITER ONE IS ENCOUNTERED (WA SET TO 1)
24173: #
24174: # 2) DELIMITER TWO ENCOUNTERED (WA SET TO 2)
24175: #
24176: # 3) END OF STRING ENCOUNTERED (WA SET TO 0)
24177: #
24178: # THE RESULT IS A STRING CONTAINING ALL CHARACTERS SCANNED
24179: # UP TO BUT NOT INCLUDING ANY DELIMITER CHARACTER.
24180: # THE POINTER IS LEFT POINTING PAST THE DELIMITER.
24181: #
24182: # IF ONLY ONE DELIMITER IS TO BE DETECTED, DELIMITER ONE
24183: # AND DELIMITER TWO SHOULD BE SET TO THE SAME VALUE.
24184: #
24185: # IN THE CASE WHERE THE END OF STRING IS ENCOUNTERED, THE
24186: # STRING INCLUDES ALL THE CHARACTERS TO THE END OF THE
24187: # STRING. NO FURTHER CALLS CAN BE MADE TO XSCAN UNTIL
24188: # XSCNI IS CALLED TO INITIALIZE A NEW ARGUMENT SCAN
24189: #page
24190: #
24191: # XSCAN (CONTINUED)
24192: #
24193: xscan: #prc # entry point
24194: movl r7,xscwb # preserve wb
24195: movl r$xsc,r9 # point to argument string
24196: movl 4*sclen(r9),r6 # load string length
24197: movl xsofs,r7 # load current offset
24198: subl2 r7,r6 # get number of remaining characters
24199: tstl r6 # jump if no characters left
24200: beqlu xscn2
24201: movab cfp$f(r9)[r7],r9# point to current character
24202: #
24203: # LOOP TO SEARCH FOR DELIMITER
24204: #
24205: xscn1: movzbl (r9)+,r7 # load next character
24206: cmpl r7,r8 # jump if delimiter one found
24207: beqlu xscn3
24208: cmpl r7,r10 # jump if delimiter two found
24209: beqlu xscn4
24210: decl r6 # decrement count of chars left
24211: tstl r6 # loop back if more chars to go
24212: bnequ xscn1
24213: #
24214: # HERE FOR RUNOUT
24215: #
24216: xscn2: movl r$xsc,r10 # point to string block
24217: movl 4*sclen(r10),r6 # get string length
24218: movl xsofs,r7 # load offset
24219: subl2 r7,r6 # get substring length
24220: clrl r$xsc # clear string ptr for collector
24221: clrl xscrt # set zero (runout) return code
24222: jmp xscn6 # jump to exit
24223: #page
24224: #
24225: # XSCAN (CONTINUED)
24226: #
24227: # HERE IF DELIMITER ONE FOUND
24228: #
24229: xscn3: movl $num01,xscrt # set return code
24230: jmp xscn5 # jump to merge
24231: #
24232: # HERE IF DELIMITER TWO FOUND
24233: #
24234: xscn4: movl $num02,xscrt # set return code
24235: #
24236: # MERGE HERE AFTER DETECTING A DELIMITER
24237: #
24238: xscn5: movl r$xsc,r10 # reload pointer to string
24239: movl 4*sclen(r10),r8 # get original length of string
24240: subl2 r6,r8 # minus chars left = chars scanned
24241: movl r8,r6 # move to reg for sbstr
24242: movl xsofs,r7 # set offset
24243: subl2 r7,r6 # compute length for sbstr
24244: incl r8 # adjust new cursor past delimiter
24245: movl r8,xsofs # store new offset
24246: #
24247: # COMMON EXIT POINT
24248: #
24249: xscn6: clrl r9 # clear garbage character ptr in xr
24250: jsb sbstr # build sub-string
24251: movl xscrt,r6 # load return code
24252: movl xscwb,r7 # restore wb
24253: rsb # return to xscan caller
24254: #enp # end procedure xscan
24255: #page
24256: #
24257: # XSCNI -- EXECUTION FUNCTION ARGUMENT SCAN
24258: #
24259: # XSCNI INITIALIZES THE SCAN USED FOR PROTOTYPE ARGUMENTS
24260: # IN THE CLEAR, DEFINE, LOAD, DATA, ARRAY FUNCTIONS. SEE
24261: # XSCAN FOR THE PROCEDURE WHICH IS USED AFTER THIS CALL.
24262: #
24263: # -(XS) ARGUMENT TO BE SCANNED (ON STACK)
24264: # JSR XSCNI CALL TO SCAN ARGUMENT
24265: # PPM LOC TRANSFER LOC IF ARG IS NOT STRING
24266: # PPM LOC TRANSFER LOC IF ARGUMENT IS NULL
24267: # (XS) POPPED
24268: # (XR,R$XSC) ARGUMENT (SCBLK PTR)
24269: # (WA) ARGUMENT LENGTH
24270: # (IA,RA) DESTROYED
24271: #
24272: .data 1
24273: xscni_s: .long 0
24274: .text 0
24275: xscni: movl (sp)+,xscni_s # entry point
24276: jsb gtstg # fetch argument as string
24277: .long xsci1 # jump if not convertible
24278: movl r9,r$xsc # else store scblk ptr for xscan
24279: clrl xsofs # set offset to zero
24280: tstl r6 # jump if null string
24281: beqlu xsci2
24282: addl3 $4*2,xscni_s,r11 # return to xscni caller
24283: jmp (r11)
24284: #
24285: # HERE IF ARGUMENT IS NOT A STRING
24286: #
24287: xsci1: movl xscni_s,r11 # take not-string error exit
24288: jmp *(r11)+
24289: #
24290: # HERE FOR NULL STRING
24291: #
24292: xsci2: addl3 $4*1,xscni_s,r11 # take null-string error exit
24293: jmp *(r11)+
24294: #enp # end procedure xscni
24295: #title s p i t b o l -- utility routines
24296: #
24297: # THE FOLLOWING SECTION CONTAINS UTILITY ROUTINES USED FOR
24298: # VARIOUS PURPOSES THROUGHOUT THE SYSTEM. THESE DIFFER
24299: # FROM THE PROCEDURES IN THE UTILITY PROCEDURES SECTION IN
24300: # THEY ARE NOT IN PROCEDURE FORM AND THEY DO NOT RETURN
24301: # TO THEIR CALLERS. THEY ARE ACCESSED WITH A BRANCH TYPE
24302: # INSTRUCTION AFTER SETTING THE REGISTERS TO APPROPRIATE
24303: # PARAMETER VALUES.
24304: #
24305: # THE REGISTER VALUES REQUIRED FOR EACH ROUTINE ARE
24306: # DOCUMENTED AT THE START OF EACH ROUTINE. REGISTERS NOT
24307: # MENTIONED MAY CONTAIN ANY VALUES EXCEPT THAT XR,XL
24308: # CAN ONLY CONTAIN PROPER COLLECTABLE POINTERS.
24309: #
24310: # SOME OF THESE ROUTINES WILL TOLERATE GARBAGE POINTERS
24311: # IN XL,XR ON ENTRY. THIS IS ALWAYS DOCUMENTED AND IN
24312: # EACH CASE, THE ROUTINE CLEARS THESE GARBAGE VALUES BEFORE
24313: # EXITING AFTER COMPLETING ITS TASK.
24314: #
24315: # THE ROUTINES HAVE NAMES CONSISTING OF FIVE LETTERS
24316: # AND ARE ASSEMBLED IN ALPHABETICAL ORDER.
24317: #page
24318: # ARREF -- ARRAY REFERENCE
24319: #
24320: # (XL) MAY BE NON-COLLECTABLE
24321: # (XR) NUMBER OF SUBSCRIPTS
24322: # (WB) SET ZERO/NONZERO FOR VALUE/NAME
24323: # THE VALUE IN WB MUST BE COLLECTABLE
24324: # STACK SUBSCRIPTS AND ARRAY OPERAND
24325: # BRN ARREF JUMP TO CALL FUNCTION
24326: #
24327: # ARREF CONTINUES BY EXECUTING THE NEXT CODE WORD WITH
24328: # THE RESULT NAME OR VALUE PLACED ON TOP OF THE STACK.
24329: # TO DEAL WITH THE PROBLEM OF ACCESSING SUBSCRIPTS IN THE
24330: # ORDER OF STACKING, XL IS USED AS A SUBSCRIPT POINTER
24331: # WORKING BELOW THE STACK POINTER.
24332: #
24333: arref: #rtn
24334: movl r9,r6 # copy number of subscripts
24335: movl sp,r10 # point to stack front
24336: moval 0[r9],r9 # convert to byte offset
24337: addl2 r9,r10 # point to array operand on stack
24338: addl2 $4,r10 # final value for stack popping
24339: movl r10,arfxs # keep for later
24340: movl -(r10),r9 # load array operand pointer
24341: movl r9,r$arf # keep array pointer
24342: movl r10,r9 # save pointer to subscripts
24343: movl r$arf,r10 # point xl to possible vcblk or tbblk
24344: movl (r10),r8 # load first word
24345: cmpl r8,$b$art # jump if arblk
24346: beqlu arf01
24347: cmpl r8,$b$vct # jump if vcblk
24348: bnequ 0f
24349: jmp arf07
24350: 0:
24351: cmpl r8,$b$tbt # jump if tbblk
24352: bnequ 0f
24353: jmp arf10
24354: 0:
24355: jmp er_235 # subscripted operand is not table or array
24356: #
24357: # HERE FOR ARRAY (ARBLK)
24358: #
24359: arf01: cmpl r6,4*arndm(r10) # jump if wrong number of dims
24360: beqlu 0f
24361: jmp arf09
24362: 0:
24363: movl intv0,r5 # get initial subscript of zero
24364: movl r9,r10 # point before subscripts
24365: clrl r6 # initial offset to bounds
24366: jmp arf03 # jump into loop
24367: #
24368: # LOOP TO COMPUTE SUBSCRIPTS BY MULTIPLICATIONS
24369: #
24370: arf02: mull2 4*ardm2(r9),r5 # multiply total by next dimension
24371: #
24372: # MERGE HERE FIRST TIME
24373: #
24374: arf03: movl -(r10),r9 # load next subscript
24375: movl r5,arfsi # save current subscript
24376: movl 4*icval(r9),r5 # load integer value in case
24377: cmpl (r9),$b$icl # jump if it was an integer
24378: beqlu arf04
24379: #page
24380: #
24381: # ARREF (CONTINUED)
24382: #
24383: #
24384: jsb gtint # convert to integer
24385: .long arf12 # jump if not integer
24386: movl 4*icval(r9),r5 # if ok, load integer value
24387: #
24388: # HERE WITH INTEGER SUBSCRIPT IN (IA)
24389: #
24390: arf04: movl r$arf,r9 # point to array
24391: addl2 r6,r9 # offset to next bounds
24392: subl2 4*arlbd(r9),r5 # subtract low bound to compare
24393: bvc 0f
24394: jmp arf13
24395: 0:
24396: tstl r5 # out of range fail if too small
24397: bgeq 0f
24398: jmp arf13
24399: 0:
24400: subl2 4*ardim(r9),r5 # subtract dimension
24401: tstl r5 # out of range fail if too large
24402: blss 0f
24403: jmp arf13
24404: 0:
24405: addl2 4*ardim(r9),r5 # else restore subscript offset
24406: addl2 arfsi,r5 # add to current total
24407: addl2 $4*ardms,r6 # point to next bounds
24408: cmpl r10,sp # loop back if more to go
24409: bnequ arf02
24410: #
24411: # HERE WITH INTEGER SUBSCRIPT COMPUTED
24412: #
24413: movl r5,r6 # get as one word integer
24414: moval 0[r6],r6 # convert to offset
24415: movl r$arf,r10 # point to arblk
24416: addl2 4*arofs(r10),r6 # add offset past bounds
24417: addl2 $4,r6 # adjust for arpro field
24418: tstl r7 # exit with name if name call
24419: bnequ arf08
24420: #
24421: # MERGE HERE TO GET VALUE FOR VALUE CALL
24422: #
24423: arf05: jsb acess # get value
24424: .long arf13 # fail if acess fails
24425: #
24426: # RETURN VALUE
24427: #
24428: arf06: movl arfxs,sp # pop stack entries
24429: clrl r$arf # finished with array pointer
24430: jmp exixr # exit with value in xr
24431: #page
24432: #
24433: # ARREF (CONTINUED)
24434: #
24435: # HERE FOR VECTOR
24436: #
24437: arf07: cmpl r6,$num01 # error if more than 1 subscript
24438: beqlu 0f
24439: jmp arf09
24440: 0:
24441: movl (sp),r9 # else load subscript
24442: jsb gtint # convert to integer
24443: .long arf12 # error if not integer
24444: movl 4*icval(r9),r5 # else load integer value
24445: subl2 intv1,r5 # subtract for ones offset
24446: movl r5,r6 # get subscript as one word
24447: bgeq 0f
24448: jmp arf13
24449: 0:
24450: addl2 $vcvls,r6 # add offset for standard fields
24451: moval 0[r6],r6 # convert offset to bytes
24452: cmpl r6,4*vclen(r10) # fail if out of range subscript
24453: blssu 0f
24454: jmp arf13
24455: 0:
24456: tstl r7 # back to get value if value call
24457: beqlu arf05
24458: #
24459: # RETURN NAME
24460: #
24461: arf08: movl arfxs,sp # pop stack entries
24462: clrl r$arf # finished with array pointer
24463: jmp exnam # else exit with name
24464: #
24465: # HERE IF SUBSCRIPT COUNT IS WRONG
24466: #
24467: arf09: jmp er_236 # array referenced with wrong number of subscripts
24468: #
24469: # TABLE
24470: #
24471: arf10: cmpl r6,$num01 # error if more than 1 subscript
24472: bnequ arf11
24473: movl (sp),r9 # else load subscript
24474: jsb tfind # call table search routine
24475: .long arf13 # fail if failed
24476: tstl r7 # exit with name if name call
24477: bnequ arf08
24478: jmp arf06 # else exit with value
24479: #
24480: # HERE FOR BAD TABLE REFERENCE
24481: #
24482: arf11: jmp er_237 # table referenced with more than one subscript
24483: #
24484: # HERE FOR BAD SUBSCRIPT
24485: #
24486: arf12: jmp er_238 # array subscript is not integer
24487: #
24488: # HERE TO SIGNAL FAILURE
24489: #
24490: arf13: clrl r$arf # finished with array pointer
24491: jmp exfal # fail
24492: #page
24493: #
24494: # CFUNC -- CALL A FUNCTION
24495: #
24496: # CFUNC IS USED TO CALL A SNOBOL LEVEL FUNCTION. IT IS
24497: # USED BY THE APPLY FUNCTION (S$APP), THE FUNCTION
24498: # TRACE ROUTINE (TRXEQ) AND THE MAIN FUNCTION CALL ENTRY
24499: # (O$FNC, O$FNS). IN THE LATTER CASES, CFUNC IS USED ONLY
24500: # IF THE NUMBER OF ARGUMENTS IS INCORRECT.
24501: #
24502: # (XL) POINTER TO FUNCTION BLOCK
24503: # (WA) ACTUAL NUMBER OF ARGUMENTS
24504: # (XS) POINTS TO STACKED ARGUMENTS
24505: # BRN CFUNC JUMP TO CALL FUNCTION
24506: #
24507: # CFUNC CONTINUES BY EXECUTING THE FUNCTION
24508: #
24509: cfunc: #rtn
24510: cmpl r6,4*fargs(r10) # jump if too few arguments
24511: blssu cfnc1
24512: cmpl r6,4*fargs(r10) # jump if correct number of args
24513: beqlu cfnc3
24514: #
24515: # HERE IF TOO MANY ARGUMENTS SUPPLIED, POP THEM OFF
24516: #
24517: movl r6,r7 # copy actual number
24518: subl2 4*fargs(r10),r7 # get number of extra args
24519: moval 0[r7],r7 # convert to bytes
24520: addl2 r7,sp # pop off unwanted arguments
24521: jmp cfnc3 # jump to go off to function
24522: #
24523: # HERE IF TOO FEW ARGUMENTS
24524: #
24525: cfnc1: movl 4*fargs(r10),r7 # load required number of arguments
24526: cmpl r7,$nini9 # jump if case of var num of args
24527: beqlu cfnc3
24528: subl2 r6,r7 # calculate number missing
24529: # set counter to control loop
24530: #
24531: # LOOP TO SUPPLY EXTRA NULL ARGUMENTS
24532: #
24533: cfnc2: movl $nulls,-(sp) # stack a null argument
24534: sobgtr r7,cfnc2 # loop till proper number stacked
24535: #
24536: # MERGE HERE TO JUMP TO FUNCTION
24537: #
24538: cfnc3: movl (r10),r11 # jump through fcode field
24539: jmp (r11)
24540: #page
24541: #
24542: # EXFAL -- EXIT SIGNALLING SNOBOL FAILURE
24543: #
24544: # (XL,XR) MAY BE NON-COLLECTABLE
24545: # BRN EXFAL JUMP TO FAIL
24546: #
24547: # EXFAL CONTINUES BY EXECUTING THE APPROPRIATE FAIL GOTO
24548: #
24549: exfal: #rtn
24550: movl flptr,sp # pop stack
24551: movl (sp),r9 # load failure offset
24552: addl2 r$cod,r9 # point to failure code location
24553: movl r9,r3 # set code pointer
24554: jmp exits # do next code word
24555: #page
24556: #
24557: # EXINT -- EXIT WITH INTEGER RESULT
24558: #
24559: # (XL,XR) MAY BE NONCOLLECTABLE
24560: # (IA) INTEGER VALUE
24561: # BRN EXINT JUMP TO EXIT WITH INTEGER
24562: #
24563: # EXINT CONTINUES BY EXECUTING THE NEXT CODE WORD
24564: # WHICH IT DOES BY FALLING THROUGH TO EXIXR
24565: #
24566: exint: #rtn
24567: jsb icbld # build icblk
24568: #page
24569: # EXIXR -- EXIT WITH RESULT IN (XR)
24570: #
24571: # (XR) RESULT
24572: # (XL) MAY BE NON-COLLECTABLE
24573: # BRN EXIXR JUMP TO EXIT WITH RESULT IN (XR)
24574: #
24575: # EXIXR CONTINUES BY EXECUTING THE NEXT CODE WORD
24576: # WHICH IT DOES BY FALLING THROUGH TO EXITS.
24577: exixr: #rtn
24578: #
24579: movl r9,-(sp) # stack result
24580: #
24581: #
24582: # EXITS -- EXIT WITH RESULT IF ANY STACKED
24583: #
24584: # (XR,XL) MAY BE NON-COLLECTABLE
24585: #
24586: # BRN EXITS ENTER EXITS ROUTINE
24587: #
24588: exits: #rtn
24589: movl (r3)+,r9 # load next code word
24590: movl (r9),r10 # load entry address
24591: movl r10,r11 # jump to execute next code word
24592: jmp (r11)
24593: #page
24594: #
24595: # EXNAM -- EXIT WITH NAME IN (XL,WA)
24596: #
24597: # (XL) NAME BASE
24598: # (WA) NAME OFFSET
24599: # (XR) MAY BE NON-COLLECTABLE
24600: # BRN EXNAM JUMP TO EXIT WITH NAME IN (XL,WA)
24601: #
24602: # EXNAM CONTINUES BY EXECUTING THE NEXT CODE WORD
24603: #
24604: exnam: #rtn
24605: movl r10,-(sp) # stack name base
24606: movl r6,-(sp) # stack name offset
24607: jmp exits # do next code word
24608: #page
24609: #
24610: # EXNUL -- EXIT WITH NULL RESULT
24611: #
24612: # (XL,XR) MAY BE NON-COLLECTABLE
24613: # BRN EXNUL JUMP TO EXIT WITH NULL VALUE
24614: #
24615: # EXNUL CONTINUES BY EXECUTING THE NEXT CODE WORD
24616: #
24617: exnul: #rtn
24618: movl $nulls,-(sp) # stack null value
24619: jmp exits # do next code word
24620: #page
24621: #
24622: # EXREA -- EXIT WITH REAL RESULT
24623: #
24624: # (XL,XR) MAY BE NON-COLLECTABLE
24625: # (RA) REAL VALUE
24626: # BRN EXREA JUMP TO EXIT WITH REAL VALUE
24627: #
24628: # EXREA CONTINUES BY EXECUTING THE NEXT CODE WORD
24629: #
24630: exrea: #rtn
24631: jsb rcbld # build rcblk
24632: jmp exixr # jump to exit with result in xr
24633: #page
24634: #
24635: # EXSID -- EXIT SETTING ID FIELD
24636: #
24637: # EXSID IS USED TO EXIT AFTER BUILDING ANY OF THE FOLLOWING
24638: # BLOCKS (ARBLK, TBBLK, PDBLK, VCBLK). IT SETS THE IDVAL.
24639: #
24640: # (XR) PTR TO BLOCK WITH IDVAL FIELD
24641: # (XL) MAY BE NON-COLLECTABLE
24642: # BRN EXSID JUMP TO EXIT AFTER SETTING ID FIELD
24643: #
24644: # EXSID CONTINUES BY EXECUTING THE NEXT CODE WORD
24645: #
24646: exsid: #rtn
24647: movl curid,r6 # load current id value
24648: cmpl r6,$cfp$m # jump if no overflow
24649: bnequ exsi1
24650: clrl r6 # else reset for wraparound
24651: #
24652: # HERE WITH OLD IDVAL IN WA
24653: #
24654: exsi1: incl r6 # bump id value
24655: movl r6,curid # store for next time
24656: movl r6,4*idval(r9) # store id value
24657: jmp exixr # exit with result in (xr)
24658: #page
24659: #
24660: # EXVNM -- EXIT WITH NAME OF VARIABLE
24661: #
24662: # EXVNM EXITS AFTER STACKING A VALUE WHICH IS A NMBLK
24663: # REFERENCING THE NAME OF A GIVEN NATURAL VARIABLE.
24664: #
24665: # (XR) VRBLK POINTER
24666: # (XL) MAY BE NON-COLLECTABLE
24667: # BRN EXVNM EXIT WITH VRBLK POINTER IN XR
24668: #
24669: exvnm: #rtn
24670: movl r9,r10 # copy name base pointer
24671: movl $4*nmsi$,r6 # set size of nmblk
24672: jsb alloc # allocate nmblk
24673: movl $b$nml,(r9) # store type word
24674: movl r10,4*nmbas(r9) # store name base
24675: movl $4*vrval,4*nmofs(r9) # store name offset
24676: jmp exixr # exit with result in xr
24677: #page
24678: #
24679: # FLPOP -- FAIL AND POP IN PATTERN MATCHING
24680: #
24681: # FLPOP POPS THE NODE AND CURSOR ON THE STACK AND THEN
24682: # DROPS THROUGH INTO FAILP TO CAUSE PATTERN FAILURE
24683: #
24684: # (XL,XR) MAY BE NON-COLLECTABLE
24685: # BRN FLPOP JUMP TO FAIL AND POP STACK
24686: #
24687: flpop: #rtn
24688: addl2 $4*num02,sp # pop two entries off stack
24689: #page
24690: #
24691: # FAILP -- FAILURE IN MATCHING PATTERN NODE
24692: #
24693: # FAILP IS USED AFTER FAILING TO MATCH A PATTERN NODE.
24694: # SEE PATTERN MATCH ROUTINES FOR DETAILS OF USE.
24695: #
24696: # (XL,XR) MAY BE NON-COLLECTABLE
24697: # BRN FAILP SIGNAL FAILURE TO MATCH
24698: #
24699: # FAILP CONTINUES BY MATCHING AN ALTERNATIVE FROM THE STACK
24700: #
24701: failp: #rtn
24702: movl (sp)+,r9 # load alternative node pointer
24703: movl (sp)+,r7 # restore old cursor
24704: movl (r9),r10 # load pcode entry pointer
24705: movl r10,r11 # jump to execute code for node
24706: jmp (r11)
24707: #page
24708: #
24709: # INDIR -- COMPUTE INDIRECT REFERENCE
24710: #
24711: # (WB) NONZERO/ZERO FOR BY NAME/VALUE
24712: # BRN INDIR JUMP TO GET INDIRECT REF ON STACK
24713: #
24714: # INDIR CONTINUES BY EXECUTING THE NEXT CODE WORD
24715: #
24716: indir: #rtn
24717: movl (sp)+,r9 # load argument
24718: cmpl (r9),$b$nml # jump if a name
24719: beqlu indr2
24720: jsb gtnvr # else convert to variable
24721: .long er_239 # indirection operand is not name
24722: tstl r7 # skip if by value
24723: beqlu indr1
24724: movl r9,-(sp) # else stack vrblk ptr
24725: movl $4*vrval,-(sp) # stack name offset
24726: jmp exits # exit with result on stack
24727: #
24728: # HERE TO GET VALUE OF NATURAL VARIABLE
24729: #
24730: indr1: movl (r9),r11 # jump through vrget field of vrblk
24731: jmp (r11)
24732: #
24733: # HERE IF OPERAND IS A NAME
24734: #
24735: indr2: movl 4*nmbas(r9),r10 # load name base
24736: movl 4*nmofs(r9),r6 # load name offset
24737: tstl r7 # exit if called by name
24738: beqlu 0f
24739: jmp exnam
24740: 0:
24741: jsb acess # else get value first
24742: .long exfal # fail if access fails
24743: jmp exixr # else return with value in xr
24744: #page
24745: #
24746: # MATCH -- INITIATE PATTERN MATCH
24747: #
24748: # (WB) MATCH TYPE CODE
24749: # BRN MATCH JUMP TO INITIATE PATTERN MATCH
24750: #
24751: # MATCH CONTINUES BY EXECUTING THE PATTERN MATCH. SEE
24752: # PATTERN MATCH ROUTINES (P$XXX) FOR FULL DETAILS.
24753: #
24754: match: #rtn
24755: movl (sp)+,r9 # load pattern operand
24756: jsb gtpat # convert to pattern
24757: .long er_240 # pattern match right operand is not pattern
24758: movl r9,r10 # if ok, save pattern pointer
24759: tstl r7 # jump if not match by name
24760: bnequ mtch1
24761: movl (sp),r6 # else load name offset
24762: movl r10,-(sp) # save pattern pointer
24763: movl 4*2(sp),r10 # load name base
24764: jsb acess # access subject value
24765: .long exfal # fail if access fails
24766: movl (sp),r10 # restore pattern pointer
24767: movl r9,(sp) # stack subject string val for merge
24768: clrl r7 # restore type code
24769: #
24770: # MERGE HERE WITH SUBJECT VALUE ON STACK
24771: #
24772: mtch1: movl (sp),r9 # load subject value
24773: clrl r$pmb # assume not a buffer
24774: cmpl (r9),$b$bct # branch if not
24775: bnequ mtcha
24776: addl2 $4,sp # else pop value
24777: movl r9,r$pmb # save pointer
24778: movl 4*bclen(r9),r6 # get defined length
24779: movl 4*bcbuf(r9),r9 # point to bfblk
24780: jmp mtchb
24781: #
24782: # HERE IF NOT BUFFER TO CONVERT TO STRING
24783: #
24784: mtcha: jsb gtstg # not buffer - convert to string
24785: .long er_241 # pattern match left operand is not string
24786: #
24787: # MERGE WITH BUFFER OR STRING
24788: #
24789: mtchb: movl r9,r$pms # if ok, store subject string pointer
24790: movl r6,pmssl # and length
24791: movl r7,-(sp) # stack match type code
24792: clrl -(sp) # stack initial cursor (zero)
24793: clrl r7 # set initial cursor
24794: movl sp,pmhbs # set history stack base ptr
24795: clrl pmdfl # reset pattern assignment flag
24796: movl r10,r9 # set initial node pointer
24797: tstl kvanc # jump if anchored
24798: bnequ mtch2
24799: #
24800: # HERE FOR UNANCHORED
24801: #
24802: movl r9,-(sp) # stack initial node pointer
24803: movl $nduna,-(sp) # stack pointer to anchor move node
24804: movl (r9),r11 # start match of first node
24805: jmp (r11)
24806: #
24807: # HERE IN ANCHORED MODE
24808: #
24809: mtch2: clrl -(sp) # dummy cursor value
24810: movl $ndabo,-(sp) # stack pointer to abort node
24811: movl (r9),r11 # start match of first node
24812: jmp (r11)
24813: #page
24814: #
24815: # RETRN -- RETURN FROM FUNCTION
24816: #
24817: # (WA) STRING POINTER FOR RETURN TYPE
24818: # BRN RETRN JUMP TO RETURN FROM (SNOBOL) FUNC
24819: #
24820: # RETRN CONTINUES BY EXECUTING THE CODE AT THE RETURN POINT
24821: # THE STACK IS CLEANED OF ANY GARBAGE LEFT BY OTHER
24822: # ROUTINES WHICH MAY HAVE ALTERED FLPTR SINCE FUNCTION
24823: # ENTRY BY USING FLPRT, RESERVED FOR USE ONLY BY
24824: # FUNCTION CALL AND RETURN.
24825: #
24826: retrn: #rtn
24827: tstl kvfnc # jump if not level zero
24828: bnequ rtn01
24829: jmp er_242 # function return from level zero
24830: #
24831: # HERE IF NOT LEVEL ZERO RETURN
24832: #
24833: rtn01: movl flprt,sp # pop stack
24834: addl2 $4,sp # remove failure offset
24835: movl (sp)+,r9 # pop pfblk pointer
24836: movl (sp)+,flptr # pop failure pointer
24837: movl (sp)+,flprt # pop old flprt
24838: movl (sp)+,r7 # pop code pointer offset
24839: movl (sp)+,r8 # pop old code block pointer
24840: addl2 r8,r7 # make old code pointer absolute
24841: movl r7,r3 # restore old code pointer
24842: movl r8,r$cod # restore old code block pointer
24843: decl kvfnc # decrement function level
24844: movl kvtra,r7 # load trace
24845: addl2 kvftr,r7 # add ftrace
24846: tstl r7 # jump if no tracing possible
24847: bnequ 0f
24848: jmp rtn06
24849: 0:
24850: #
24851: # HERE IF THERE MAY BE A TRACE
24852: #
24853: movl r6,-(sp) # save function return type
24854: movl r9,-(sp) # save pfblk pointer
24855: movl r6,kvrtn # set rtntype for trace function
24856: movl r$fnc,r10 # load fnclevel trblk ptr (if any)
24857: jsb ktrex # execute possible fnclevel trace
24858: movl 4*pfvbl(r9),r10 # load vrblk ptr (sgd13)
24859: tstl kvtra # jump if trace is off
24860: beqlu rtn02
24861: movl 4*pfrtr(r9),r9 # else load return trace trblk ptr
24862: tstl r9 # jump if not return traced
24863: beqlu rtn02
24864: decl kvtra # else decrement trace count
24865: tstl 4*trfnc(r9) # jump if print trace
24866: beqlu rtn03
24867: movl $4*vrval,r6 # else set name offset
24868: movl 4*1(sp),kvrtn # make sure rtntype is set right
24869: jsb trxeq # execute full trace
24870: #page
24871: #
24872: # RETRN (CONTINUED)
24873: #
24874: # HERE TO TEST FOR FTRACE
24875: #
24876: rtn02: tstl kvftr # jump if ftrace is off
24877: beqlu rtn05
24878: decl kvftr # else decrement ftrace
24879: #
24880: # HERE FOR PRINT TRACE OF FUNCTION RETURN
24881: #
24882: rtn03: jsb prtsn # print statement number
24883: movl 4*1(sp),r9 # load return type
24884: jsb prtst # print it
24885: movl $ch$bl,r6 # load blank
24886: jsb prtch # print it
24887: movl (sp),r10 # load pfblk ptr
24888: movl 4*pfvbl(r10),r10# load function vrblk ptr
24889: movl $4*vrval,r6 # set vrblk name offset
24890: cmpl r9,$scfrt # jump if not freturn case
24891: bnequ rtn04
24892: #
24893: # FOR FRETURN, JUST PRINT FUNCTION NAME
24894: #
24895: jsb prtnm # print name
24896: jsb prtnl # terminate print line
24897: jmp rtn05 # merge
24898: #
24899: # HERE FOR RETURN OR NRETURN, PRINT FUNCTION NAME = VALUE
24900: #
24901: rtn04: jsb prtnv # print name = value
24902: #
24903: # HERE AFTER COMPLETING TRACE
24904: #
24905: rtn05: movl (sp)+,r9 # pop pfblk pointer
24906: movl (sp)+,r6 # pop return type string
24907: #
24908: # MERGE HERE IF NO TRACE REQUIRED
24909: #
24910: rtn06: movl r6,kvrtn # set rtntype keyword
24911: movl 4*pfvbl(r9),r10 # load pointer to fn vrblk
24912: #page
24913: # RETRN (CONTINUED)
24914: #
24915: # GET VALUE OF FUNCTION
24916: #
24917: rtn07: movl r10,rtnbp # save block pointer
24918: movl 4*vrval(r10),r10# load value
24919: cmpl (r10),$b$trt # loop back if trapped
24920: beqlu rtn07
24921: movl r10,rtnfv # else save function result value
24922: movl (sp)+,rtnsv # save original function value
24923: movl (sp)+,r10 # pop saved pointer
24924: tstl r10 # no action if none
24925: beqlu rtn7c
24926: tstl kvpfl # jump if no profiling
24927: beqlu rtn7c
24928: jsb prflu # else profile last func stmt
24929: cmpl kvpfl,$num02 # branch on value of profile keywd
24930: beqlu rtn7a
24931: #
24932: # HERE IF &PROFILE = 1. START TIME MUST BE FRIGGED TO
24933: # APPEAR EARLIER THAN IT ACTUALLY IS, BY AMOUNT USED BEFORE
24934: # THE CALL.
24935: #
24936: movl pfstm,r5 # load current time
24937: subl2 4*icval(r10),r5 # frig by subtracting saved amount
24938: jmp rtn7b # and merge
24939: #
24940: # HERE IF &PROFILE = 2
24941: #
24942: rtn7a: movl 4*icval(r10),r5 # load saved time
24943: #
24944: # BOTH PROFILE TYPES MERGE HERE
24945: #
24946: rtn7b: movl r5,pfstm # store back correct start time
24947: #
24948: # MERGE HERE IF NO PROFILING
24949: #
24950: rtn7c: movl 4*fargs(r9),r7 # get number of args
24951: addl2 4*pfnlo(r9),r7 # add number of locals
24952: tstl r7 # jump if no args/locals
24953: beqlu rtn10
24954: # else set loop counter
24955: addl2 4*pflen(r9),r9 # and point to end of pfblk
24956: #
24957: # LOOP TO RESTORE FUNCTIONS AND LOCALS
24958: #
24959: rtn08: movl -(r9),r10 # load next vrblk pointer
24960: #
24961: # LOOP TO FIND VALUE BLOCK
24962: #
24963: rtn09: movl r10,r6 # save block pointer
24964: movl 4*vrval(r10),r10# load pointer to next value
24965: cmpl (r10),$b$trt # loop back if trapped
24966: beqlu rtn09
24967: movl r6,r10 # else restore last block pointer
24968: movl (sp)+,4*vrval(r10) # restore old variable value
24969: sobgtr r7,rtn08 # loop till all processed
24970: #
24971: # NOW RESTORE FUNCTION VALUE AND EXIT
24972: #
24973: rtn10: movl rtnbp,r10 # restore ptr to last function block
24974: movl rtnsv,4*vrval(r10) # restore old function value
24975: movl rtnfv,r9 # reload function result
24976: movl r$cod,r10 # point to new code block
24977: movl kvstn,kvlst # set lastno from stno
24978: movl 4*cdstm(r10),kvstn # reset proper stno value
24979: movl kvrtn,r6 # load return type
24980: cmpl r6,$scrtn # exit with result in xr if return
24981: bnequ 0f
24982: jmp exixr
24983: 0:
24984: cmpl r6,$scfrt # fail if freturn
24985: bnequ 0f
24986: jmp exfal
24987: 0:
24988: #page
24989: #
24990: # RETRN (CONTINUED)
24991: #
24992: # HERE FOR NRETURN
24993: #
24994: cmpl (r9),$b$nml # jump if is a name
24995: beqlu rtn11
24996: jsb gtnvr # else try convert to variable name
24997: .long er_243 # function result in nreturn is not name
24998: movl r9,r10 # if ok, copy vrblk (name base) ptr
24999: movl $4*vrval,r6 # set name offset
25000: jmp rtn12 # and merge
25001: #
25002: # HERE IF RETURNED RESULT IS A NAME
25003: #
25004: rtn11: movl 4*nmbas(r9),r10 # load name base
25005: movl 4*nmofs(r9),r6 # load name offset
25006: #
25007: # MERGE HERE WITH RETURNED NAME IN (XL,WA)
25008: #
25009: rtn12: movl r10,r9 # preserve xl
25010: movl (r3)+,r7 # load next word
25011: movl r9,r10 # restore xl
25012: cmpl r7,$ofne$ # exit if called by name
25013: bnequ 0f
25014: jmp exnam
25015: 0:
25016: movl r7,-(sp) # else save code word
25017: jsb acess # get value
25018: .long exfal # fail if access fails
25019: movl r9,r10 # if ok, copy result
25020: movl (sp),r9 # reload next code word
25021: movl r10,(sp) # store result on stack
25022: movl (r9),r10 # load routine address
25023: movl r10,r11 # jump to execute next code word
25024: jmp (r11)
25025: #page
25026: #
25027: # STCOV -- SIGNAL STATEMENT COUNTER OVERFLOW
25028: #
25029: # BRN STCOV JUMP TO SIGNAL STATEMENT COUNT OFLO
25030: #
25031: # PERMIT UP TO 10 MORE STATEMENTS TO BE OBEYED SO THAT
25032: # SETEXIT TRAP CAN REGAIN CONTROL.
25033: # STCOV CONTINUES BY ISSUING THE ERROR MESSAGE
25034: #
25035: stcov: #rtn
25036: incl errft # fatal error
25037: movl intvt,r5 # get 10
25038: addl2 kvstl,r5 # add to former limit
25039: movl r5,kvstl # store as new stlimit
25040: movl intvt,r5 # get 10
25041: movl r5,kvstc # set as new count
25042: jmp er_244 # statement count exceeds value of stlimit keyword
25043: #page
25044: #
25045: # STMGO -- START EXECUTION OF NEW STATEMENT
25046: #
25047: # (XR) POINTER TO CDBLK FOR NEW STATEMENT
25048: # BRN STMGO JUMP TO EXECUTE NEW STATEMENT
25049: #
25050: # STMGO CONTINUES BY EXECUTING THE NEXT STATEMENT
25051: #
25052: stmgo: #rtn
25053: movl r9,r$cod # set new code block pointer
25054: tstl kvpfl # skip if no profiling
25055: beqlu stgo1
25056: jsb prflu # else profile the statement
25057: stgo1: movl kvstn,kvlst # set lastno
25058: movl 4*cdstm(r9),kvstn# set stno
25059: addl2 $4*cdcod,r9 # point to first code word
25060: movl r9,r3 # set code pointer
25061: movl kvstc,r5 # get stmt count
25062: tstl r5 # omit counting if negative
25063: bgeq 0f
25064: jmp exits
25065: 0:
25066: tstl r5 # fail if stlimit reached
25067: beql stcov
25068: subl2 intv1,r5 # decrement
25069: movl r5,kvstc # replace it
25070: tstl r$stc # exit if no stcount trace
25071: bnequ 0f
25072: jmp exits
25073: 0:
25074: #
25075: # HERE FOR STCOUNT TRACE
25076: #
25077: clrl r9 # clear garbage value in xr
25078: movl r$stc,r10 # load pointer to stcount trblk
25079: jsb ktrex # execute keyword trace
25080: jmp exits # and then exit for next code word
25081: #page
25082: #
25083: # STOPR -- TERMINATE RUN
25084: #
25085: # (XR) POINTS TO ENDING MESSAGE
25086: # BRN STOPR JUMP TO TERMINATE RUN
25087: #
25088: # TERMINATE RUN AND PRINT STATISTICS. ON ENTRY XR POINTS
25089: # TO ENDING MESSAGE OR IS ZERO IF MESSAGE PRINTED ALREADY.
25090: #
25091: stopr: #rtn
25092: tstl r9 # skip if sysax already called (reg04)
25093: beqlu stpra
25094: jsb sysax # call after execution proc
25095: stpra: addl2 rsmem,dname # use the reserve memory
25096: cmpl r9,$endms # skip if not normal end message
25097: bnequ stpr0
25098: tstl exsts # skip if exec stats suppressed
25099: beqlu 0f
25100: jmp stpr3
25101: 0:
25102: clrl erich # clear errors to int.ch. flag
25103: #
25104: # LOOK TO SEE IF AN ENDING MESSAGE IS SUPPLIED
25105: #
25106: stpr0: jsb prtpg # eject printer
25107: tstl r9 # skip if no message
25108: beqlu stpr1
25109: jsb prtst # print message
25110: #
25111: # MERGE HERE IF NO MESSAGE TO PRINT
25112: #
25113: stpr1: jsb prtis # print blank line
25114: movl kvstn,r5 # get statement number
25115: movl $stpm1,r9 # point to message /in statement xxx/
25116: jsb prtmx # print it
25117: jsb systm # get current time
25118: subl2 timsx,r5 # minus start time = elapsed exec tim
25119: movl r5,stpti # save for later
25120: movl $stpm3,r9 # point to msg /execution time msec /
25121: jsb prtmx # print it
25122: movl kvstl,r5 # get statement limit
25123: tstl r5 # skip if negative
25124: blss stpr2
25125: subl2 kvstc,r5 # minus counter = count
25126: movl r5,stpsi # save
25127: movl $stpm2,r9 # point to message /stmts executed/
25128: jsb prtmx # print it
25129: movl stpti,r5 # reload elapsed time
25130: mull2 intth,r5 # *1000 (microsecs)
25131: bvs stpr2
25132: divl2 stpsi,r5 # divide by statement count
25133: bvs stpr2
25134: movl $stpm4,r9 # point to msg (mcsec per statement /
25135: jsb prtmx # print it
25136: #page
25137: #
25138: # STOPR (CONTINUED)
25139: #
25140: # MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT)
25141: #
25142: stpr2: movl gbcnt,r5 # load count of collections
25143: movl $stpm5,r9 # point to message /regenerations /
25144: jsb prtmx # print it
25145: jsb prtis # one more blank for luck
25146: #
25147: # CHECK IF DUMP REQUESTED
25148: #
25149: stpr3: jsb prflr # print profile if wanted
25150: #
25151: movl kvdmp,r9 # load dump keyword
25152: jsb dumpr # execute dump if requested
25153: movl r$fcb,r10 # get fcblk chain head
25154: movl kvabe,r6 # load abend value
25155: movl kvcod,r7 # load code value
25156: jsb sysej # exit to system
25157: #page
25158: #
25159: # SUCCP -- SIGNAL SUCCESSFUL MATCH OF A PATTERN NODE
25160: #
25161: # SEE PATTERN MATCH ROUTINES FOR DETAILS
25162: #
25163: # (XR) CURRENT NODE
25164: # (WB) CURRENT CURSOR
25165: # (XL) MAY BE NON-COLLECTABLE
25166: # BRN SUCCP SIGNAL SUCCESSFUL PATTERN MATCH
25167: #
25168: # SUCCP CONTINUES BY MATCHING THE SUCCESSOR NODE
25169: #
25170: succp: #rtn
25171: movl 4*pthen(r9),r9 # load successor node
25172: movl (r9),r10 # load node code entry address
25173: movl r10,r11 # jump to match successor node
25174: jmp (r11)
25175: #page
25176: #
25177: # SYSAB -- PRINT /ABNORMAL END/ AND TERMINATE
25178: #
25179: sysab: #rtn
25180: movl $endab,r9 # point to message
25181: movl $num01,kvabe # set abend flag
25182: jsb prtnl # skip to new line
25183: jmp stopr # jump to pack up
25184: #page
25185: #
25186: # SYSTU -- PRINT /TIME UP/ AND TERMINATE
25187: #
25188: systu: #rtn
25189: movl $endtu,r9 # point to message
25190: movl strtu,r6 # get chars /tu/
25191: movl r6,kvcod # put in kvcod
25192: movl timup,r6 # check state of timeup switch
25193: movl sp,timup # set switch
25194: tstl r6 # stop run if already set
25195: beqlu 0f
25196: jmp stopr
25197: 0:
25198: jmp er_245 # translation/execution time expired
25199: #title s p i t b o l -- stack overflow section
25200: #
25201: # CONTROL COMES HERE IF THE MAIN STACK OVERFLOWS
25202: #
25203: er_001: movzwl $1,r6
25204: jmp error
25205: er_002: movzwl $2,r6
25206: jmp error
25207: er_003: movzwl $3,r6
25208: jmp error
25209: er_004: movzwl $4,r6
25210: jmp error
25211: er_005: movzwl $5,r6
25212: jmp error
25213: er_006: movzwl $6,r6
25214: jmp error
25215: er_007: movzwl $7,r6
25216: jmp error
25217: er_008: movzwl $8,r6
25218: jmp error
25219: er_009: movzwl $9,r6
25220: jmp error
25221: er_010: movzwl $10,r6
25222: jmp error
25223: er_011: movzwl $11,r6
25224: jmp error
25225: er_012: movzwl $12,r6
25226: jmp error
25227: er_013: movzwl $13,r6
25228: jmp error
25229: er_014: movzwl $14,r6
25230: jmp error
25231: er_015: movzwl $15,r6
25232: jmp error
25233: er_016: movzwl $16,r6
25234: jmp error
25235: er_017: movzwl $17,r6
25236: jmp error
25237: er_018: movzwl $18,r6
25238: jmp error
25239: er_019: movzwl $19,r6
25240: jmp error
25241: er_020: movzwl $20,r6
25242: jmp error
25243: er_021: movzwl $21,r6
25244: jmp error
25245: er_022: movzwl $22,r6
25246: jmp error
25247: er_023: movzwl $23,r6
25248: jmp error
25249: er_024: movzwl $24,r6
25250: jmp error
25251: er_025: movzwl $25,r6
25252: jmp error
25253: er_026: movzwl $26,r6
25254: jmp error
25255: er_027: movzwl $27,r6
25256: jmp error
25257: er_028: movzwl $28,r6
25258: jmp error
25259: er_029: movzwl $29,r6
25260: jmp error
25261: er_030: movzwl $30,r6
25262: jmp error
25263: er_031: movzwl $31,r6
25264: jmp error
25265: er_032: movzwl $32,r6
25266: jmp error
25267: er_033: movzwl $33,r6
25268: jmp error
25269: er_034: movzwl $34,r6
25270: jmp error
25271: er_035: movzwl $35,r6
25272: jmp error
25273: er_036: movzwl $36,r6
25274: jmp error
25275: er_037: movzwl $37,r6
25276: jmp error
25277: er_038: movzwl $38,r6
25278: jmp error
25279: er_039: movzwl $39,r6
25280: jmp error
25281: er_040: movzwl $40,r6
25282: jmp error
25283: er_041: movzwl $41,r6
25284: jmp error
25285: er_042: movzwl $42,r6
25286: jmp error
25287: er_043: movzwl $43,r6
25288: jmp error
25289: er_044: movzwl $44,r6
25290: jmp error
25291: er_045: movzwl $45,r6
25292: jmp error
25293: er_046: movzwl $46,r6
25294: jmp error
25295: er_047: movzwl $47,r6
25296: jmp error
25297: er_048: movzwl $48,r6
25298: jmp error
25299: er_049: movzwl $49,r6
25300: jmp error
25301: er_050: movzwl $50,r6
25302: jmp error
25303: er_051: movzwl $51,r6
25304: jmp error
25305: er_052: movzwl $52,r6
25306: jmp error
25307: er_053: movzwl $53,r6
25308: jmp error
25309: er_054: movzwl $54,r6
25310: jmp error
25311: er_055: movzwl $55,r6
25312: jmp error
25313: er_056: movzwl $56,r6
25314: jmp error
25315: er_057: movzwl $57,r6
25316: jmp error
25317: er_058: movzwl $58,r6
25318: jmp error
25319: er_059: movzwl $59,r6
25320: jmp error
25321: er_060: movzwl $60,r6
25322: jmp error
25323: er_061: movzwl $61,r6
25324: jmp error
25325: er_062: movzwl $62,r6
25326: jmp error
25327: er_063: movzwl $63,r6
25328: jmp error
25329: er_064: movzwl $64,r6
25330: jmp error
25331: er_065: movzwl $65,r6
25332: jmp error
25333: er_066: movzwl $66,r6
25334: jmp error
25335: er_067: movzwl $67,r6
25336: jmp error
25337: er_068: movzwl $68,r6
25338: jmp error
25339: er_069: movzwl $69,r6
25340: jmp error
25341: er_070: movzwl $70,r6
25342: jmp error
25343: er_071: movzwl $71,r6
25344: jmp error
25345: er_072: movzwl $72,r6
25346: jmp error
25347: er_073: movzwl $73,r6
25348: jmp error
25349: er_074: movzwl $74,r6
25350: jmp error
25351: er_075: movzwl $75,r6
25352: jmp error
25353: er_076: movzwl $76,r6
25354: jmp error
25355: er_077: movzwl $77,r6
25356: jmp error
25357: er_078: movzwl $78,r6
25358: jmp error
25359: er_079: movzwl $79,r6
25360: jmp error
25361: er_080: movzwl $80,r6
25362: jmp error
25363: er_081: movzwl $81,r6
25364: jmp error
25365: er_082: movzwl $82,r6
25366: jmp error
25367: er_083: movzwl $83,r6
25368: jmp error
25369: er_084: movzwl $84,r6
25370: jmp error
25371: er_085: movzwl $85,r6
25372: jmp error
25373: er_086: movzwl $86,r6
25374: jmp error
25375: er_087: movzwl $87,r6
25376: jmp error
25377: er_088: movzwl $88,r6
25378: jmp error
25379: er_089: movzwl $89,r6
25380: jmp error
25381: er_090: movzwl $90,r6
25382: jmp error
25383: er_091: movzwl $91,r6
25384: jmp error
25385: er_092: movzwl $92,r6
25386: jmp error
25387: er_093: movzwl $93,r6
25388: jmp error
25389: er_094: movzwl $94,r6
25390: jmp error
25391: er_095: movzwl $95,r6
25392: jmp error
25393: er_096: movzwl $96,r6
25394: jmp error
25395: er_097: movzwl $97,r6
25396: jmp error
25397: er_098: movzwl $98,r6
25398: jmp error
25399: er_099: movzwl $99,r6
25400: jmp error
25401: er_100: movzwl $100,r6
25402: jmp error
25403: er_101: movzwl $101,r6
25404: jmp error
25405: er_102: movzwl $102,r6
25406: jmp error
25407: er_103: movzwl $103,r6
25408: jmp error
25409: er_104: movzwl $104,r6
25410: jmp error
25411: er_105: movzwl $105,r6
25412: jmp error
25413: er_106: movzwl $106,r6
25414: jmp error
25415: er_107: movzwl $107,r6
25416: jmp error
25417: er_108: movzwl $108,r6
25418: jmp error
25419: er_109: movzwl $109,r6
25420: jmp error
25421: er_110: movzwl $110,r6
25422: jmp error
25423: er_111: movzwl $111,r6
25424: jmp error
25425: er_112: movzwl $112,r6
25426: jmp error
25427: er_113: movzwl $113,r6
25428: jmp error
25429: er_114: movzwl $114,r6
25430: jmp error
25431: er_115: movzwl $115,r6
25432: jmp error
25433: er_116: movzwl $116,r6
25434: jmp error
25435: er_117: movzwl $117,r6
25436: jmp error
25437: er_118: movzwl $118,r6
25438: jmp error
25439: er_119: movzwl $119,r6
25440: jmp error
25441: er_120: movzwl $120,r6
25442: jmp error
25443: er_121: movzwl $121,r6
25444: jmp error
25445: er_122: movzwl $122,r6
25446: jmp error
25447: er_123: movzwl $123,r6
25448: jmp error
25449: er_124: movzwl $124,r6
25450: jmp error
25451: er_125: movzwl $125,r6
25452: jmp error
25453: er_126: movzwl $126,r6
25454: jmp error
25455: er_127: movzwl $127,r6
25456: jmp error
25457: er_128: movzwl $128,r6
25458: jmp error
25459: er_129: movzwl $129,r6
25460: jmp error
25461: er_130: movzwl $130,r6
25462: jmp error
25463: er_131: movzwl $131,r6
25464: jmp error
25465: er_132: movzwl $132,r6
25466: jmp error
25467: er_133: movzwl $133,r6
25468: jmp error
25469: er_134: movzwl $134,r6
25470: jmp error
25471: er_135: movzwl $135,r6
25472: jmp error
25473: er_136: movzwl $136,r6
25474: jmp error
25475: er_137: movzwl $137,r6
25476: jmp error
25477: er_138: movzwl $138,r6
25478: jmp error
25479: er_139: movzwl $139,r6
25480: jmp error
25481: er_140: movzwl $140,r6
25482: jmp error
25483: er_141: movzwl $141,r6
25484: jmp error
25485: er_142: movzwl $142,r6
25486: jmp error
25487: er_143: movzwl $143,r6
25488: jmp error
25489: er_144: movzwl $144,r6
25490: jmp error
25491: er_145: movzwl $145,r6
25492: jmp error
25493: er_146: movzwl $146,r6
25494: jmp error
25495: er_147: movzwl $147,r6
25496: jmp error
25497: er_148: movzwl $148,r6
25498: jmp error
25499: er_149: movzwl $149,r6
25500: jmp error
25501: er_150: movzwl $150,r6
25502: jmp error
25503: er_151: movzwl $151,r6
25504: jmp error
25505: er_152: movzwl $152,r6
25506: jmp error
25507: er_153: movzwl $153,r6
25508: jmp error
25509: er_154: movzwl $154,r6
25510: jmp error
25511: er_155: movzwl $155,r6
25512: jmp error
25513: er_156: movzwl $156,r6
25514: jmp error
25515: er_157: movzwl $157,r6
25516: jmp error
25517: er_158: movzwl $158,r6
25518: jmp error
25519: er_159: movzwl $159,r6
25520: jmp error
25521: er_160: movzwl $160,r6
25522: jmp error
25523: er_161: movzwl $161,r6
25524: jmp error
25525: er_162: movzwl $162,r6
25526: jmp error
25527: er_163: movzwl $163,r6
25528: jmp error
25529: er_164: movzwl $164,r6
25530: jmp error
25531: er_165: movzwl $165,r6
25532: jmp error
25533: er_166: movzwl $166,r6
25534: jmp error
25535: er_167: movzwl $167,r6
25536: jmp error
25537: er_168: movzwl $168,r6
25538: jmp error
25539: er_169: movzwl $169,r6
25540: jmp error
25541: er_170: movzwl $170,r6
25542: jmp error
25543: er_171: movzwl $171,r6
25544: jmp error
25545: er_172: movzwl $172,r6
25546: jmp error
25547: er_173: movzwl $173,r6
25548: jmp error
25549: er_174: movzwl $174,r6
25550: jmp error
25551: er_175: movzwl $175,r6
25552: jmp error
25553: er_176: movzwl $176,r6
25554: jmp error
25555: er_177: movzwl $177,r6
25556: jmp error
25557: er_178: movzwl $178,r6
25558: jmp error
25559: er_179: movzwl $179,r6
25560: jmp error
25561: er_180: movzwl $180,r6
25562: jmp error
25563: er_181: movzwl $181,r6
25564: jmp error
25565: er_182: movzwl $182,r6
25566: jmp error
25567: er_183: movzwl $183,r6
25568: jmp error
25569: er_184: movzwl $184,r6
25570: jmp error
25571: er_185: movzwl $185,r6
25572: jmp error
25573: er_186: movzwl $186,r6
25574: jmp error
25575: er_187: movzwl $187,r6
25576: jmp error
25577: er_188: movzwl $188,r6
25578: jmp error
25579: er_189: movzwl $189,r6
25580: jmp error
25581: er_190: movzwl $190,r6
25582: jmp error
25583: er_191: movzwl $191,r6
25584: jmp error
25585: er_192: movzwl $192,r6
25586: jmp error
25587: er_193: movzwl $193,r6
25588: jmp error
25589: er_194: movzwl $194,r6
25590: jmp error
25591: er_195: movzwl $195,r6
25592: jmp error
25593: er_196: movzwl $196,r6
25594: jmp error
25595: er_197: movzwl $197,r6
25596: jmp error
25597: er_198: movzwl $198,r6
25598: jmp error
25599: er_199: movzwl $199,r6
25600: jmp error
25601: er_200: movzwl $200,r6
25602: jmp error
25603: er_201: movzwl $201,r6
25604: jmp error
25605: er_202: movzwl $202,r6
25606: jmp error
25607: er_203: movzwl $203,r6
25608: jmp error
25609: er_204: movzwl $204,r6
25610: jmp error
25611: er_205: movzwl $205,r6
25612: jmp error
25613: er_206: movzwl $206,r6
25614: jmp error
25615: er_207: movzwl $207,r6
25616: jmp error
25617: er_208: movzwl $208,r6
25618: jmp error
25619: er_209: movzwl $209,r6
25620: jmp error
25621: er_210: movzwl $210,r6
25622: jmp error
25623: er_211: movzwl $211,r6
25624: jmp error
25625: er_212: movzwl $212,r6
25626: jmp error
25627: er_213: movzwl $213,r6
25628: jmp error
25629: er_214: movzwl $214,r6
25630: jmp error
25631: er_215: movzwl $215,r6
25632: jmp error
25633: er_216: movzwl $216,r6
25634: jmp error
25635: er_217: movzwl $217,r6
25636: jmp error
25637: er_218: movzwl $218,r6
25638: jmp error
25639: er_219: movzwl $219,r6
25640: jmp error
25641: er_220: movzwl $220,r6
25642: jmp error
25643: er_221: movzwl $221,r6
25644: jmp error
25645: er_222: movzwl $222,r6
25646: jmp error
25647: er_223: movzwl $223,r6
25648: jmp error
25649: er_224: movzwl $224,r6
25650: jmp error
25651: er_225: movzwl $225,r6
25652: jmp error
25653: er_226: movzwl $226,r6
25654: jmp error
25655: er_227: movzwl $227,r6
25656: jmp error
25657: er_228: movzwl $228,r6
25658: jmp error
25659: er_229: movzwl $229,r6
25660: jmp error
25661: er_230: movzwl $230,r6
25662: jmp error
25663: er_231: movzwl $231,r6
25664: jmp error
25665: er_232: movzwl $232,r6
25666: jmp error
25667: er_233: movzwl $233,r6
25668: jmp error
25669: er_234: movzwl $234,r6
25670: jmp error
25671: er_235: movzwl $235,r6
25672: jmp error
25673: er_236: movzwl $236,r6
25674: jmp error
25675: er_237: movzwl $237,r6
25676: jmp error
25677: er_238: movzwl $238,r6
25678: jmp error
25679: er_239: movzwl $239,r6
25680: jmp error
25681: er_240: movzwl $240,r6
25682: jmp error
25683: er_241: movzwl $241,r6
25684: jmp error
25685: er_242: movzwl $242,r6
25686: jmp error
25687: er_243: movzwl $243,r6
25688: jmp error
25689: er_244: movzwl $244,r6
25690: jmp error
25691: er_245: movzwl $245,r6
25692: jmp error
25693: er_246: movzwl $246,r6
25694: jmp error
25695: er_247: movzwl $247,r6
25696: jmp error
25697: er_248: movzwl $248,r6
25698: jmp error
25699: er_249: movzwl $249,r6
25700: jmp error
25701: er_250: movzwl $250,r6
25702: jmp error
25703: er_251: movzwl $251,r6
25704: jmp error
25705: er_252: movzwl $252,r6
25706: jmp error
25707: er_253: movzwl $253,r6
25708: jmp error
25709: er_254: movzwl $254,r6
25710: jmp error
25711: er_255: movzwl $255,r6
25712: jmp error
25713: er_256: movzwl $256,r6
25714: jmp error
25715: er_257: movzwl $257,r6
25716: jmp error
25717: er_258: movzwl $258,r6
25718: jmp error
25719: er_259: movzwl $259,r6
25720: jmp error
25721: er_260: movzwl $260,r6
25722: jmp error
25723: er_261: movzwl $261,r6
25724: jmp error
25725: er_262: movzwl $262,r6
25726: jmp error
25727: er_263: movzwl $263,r6
25728: jmp error
25729: er_264: movzwl $264,r6
25730: jmp error
25731: er_265: movzwl $265,r6
25732: jmp error
25733: er_266: movzwl $266,r6
25734: jmp error
25735: er_267: movzwl $267,r6
25736: jmp error
25737: er_268: movzwl $268,r6
25738: jmp error
25739: er_269: movzwl $269,r6
25740: jmp error
25741: er_270: movzwl $270,r6
25742: jmp error
25743: er_271: movzwl $271,r6
25744: jmp error
25745: er_272: movzwl $272,r6
25746: jmp error
25747: er_273: movzwl $273,r6
25748: jmp error
25749: er_274: movzwl $274,r6
25750: jmp error
25751: er_275: movzwl $275,r6
25752: jmp error
25753: er_276: movzwl $276,r6
25754: jmp error
25755: er_277: movzwl $277,r6
25756: jmp error
25757: er_278: movzwl $278,r6
25758: jmp error
25759: er_279: movzwl $279,r6
25760: jmp error
25761: er_280: movzwl $280,r6
25762: jmp error
25763: er_281: movzwl $281,r6
25764: jmp error
25765: er_282: movzwl $282,r6
25766: jmp error
25767: er_283: movzwl $283,r6
25768: jmp error
25769: er_284: movzwl $284,r6
25770: jmp error
25771: er_285: movzwl $285,r6
25772: jmp error
25773: er_286: movzwl $286,r6
25774: jmp error
25775: er_287: movzwl $287,r6
25776: jmp error
25777: er_288: movzwl $288,r6
25778: jmp error
25779: er_289: movzwl $289,r6
25780: jmp error
25781: er_290: movzwl $290,r6
25782: jmp error
25783: er_291: movzwl $291,r6
25784: jmp error
25785: er_292: movzwl $292,r6
25786: jmp error
25787: er_293: movzwl $293,r6
25788: jmp error
25789: er_294: movzwl $294,r6
25790: jmp error
25791: er_295: movzwl $295,r6
25792: jmp error
25793: er_296: movzwl $296,r6
25794: jmp error
25795: er_297: movzwl $297,r6
25796: jmp error
25797: .globl sec05
25798: sec05:
25799: #sec # start of stack overflow section
25800: #
25801: incl errft # fatal error
25802: movl flptr,sp # pop stack to avoid more fails
25803: tstl gbcfl # jump if garbage collecting
25804: bnequ stak1
25805: jmp er_246 # stack overflow
25806: #
25807: # NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION
25808: #
25809: stak1: movl $endso,r9 # point to message
25810: clrl kvdmp # memory is undumpable
25811: jmp stopr # give up
25812: #title s p i t b o l -- error section
25813: #
25814: # THIS SECTION OF CODE IS ENTERED WHENEVER A PROCEDURE
25815: # RETURN VIA AN ERR PARAMETER OR AN ERB OPCODE IS OBEYED.
25816: #
25817: # (WA) IS THE ERROR CODE
25818: #
25819: # THE GLOBAL VARIABLE STAGE INDICATES THE POINT AT WHICH
25820: # THE ERROR OCCURED AS FOLLOWS.
25821: #
25822: # STAGE=STGIC ERROR DURING INITIAL COMPILE
25823: #
25824: # STAGE=STGXC ERROR DURING COMPILE AT EXECUTE
25825: # TIME (CODE, CONVERT FUNCTION CALLS)
25826: #
25827: # STAGE=STGEV ERROR DURING COMPILATION OF
25828: # EXPRESSION AT EXECUTION TIME
25829: # (EVAL, CONVERT FUNCTION CALL).
25830: #
25831: # STAGE=STGXT ERROR AT EXECUTE TIME. COMPILER
25832: # NOT ACTIVE.
25833: #
25834: # STAGE=STGCE ERROR DURING INITIAL COMPILE AFTER
25835: # SCANNING OUT THE END LINE.
25836: #
25837: # STAGE=STGXE ERROR DURING COMPILE AT EXECUTE
25838: # TIME AFTER SCANNING END LINE.
25839: #
25840: # STAGE=STGEE ERROR DURING EXPRESSION EVALUATION
25841: #
25842: #sec # start of error section
25843: #
25844: error: cmpl r$cim,$cmlab # jump if error in scanning label
25845: bnequ 0f
25846: jmp cmple
25847: 0:
25848: movl r6,kvert # save error code
25849: clrl scnrs # reset rescan switch for scane
25850: clrl scngo # reset goto switch for scane
25851: movl stage,r9 # load current stage
25852: casel r9,$0,$stgno # jump to appropriate error circuit
25853: 5:
25854: .word err01-5b # initial compile
25855: .word err04-5b # execute time compile
25856: .word err04-5b # eval compiling expr.
25857: .word err05-5b # execute time
25858: .word err01-5b # compile - after end
25859: .word err04-5b # xeq compile-past end
25860: .word err04-5b # eval evaluating expr
25861: #esw # end switch on error type
25862: #page
25863: #
25864: # ERROR DURING INITIAL COMPILE
25865: #
25866: # THE ERROR MESSAGE IS PRINTED AS PART OF THE COMPILER
25867: # OUTPUT. THIS PRINTOUT INCLUDES THE OFFENDING LINE (IF NOT
25868: # PRINTED ALREADY) AND AN ERROR FLAG UNDER THE APPROPRIATE
25869: # COLUMN AS INDICATED BY SCNSE UNLESS SCNSE IS SET TO ZERO.
25870: #
25871: # AFTER PRINTING THE MESSAGE, THE GENERATED CODE IS
25872: # MODIFIED TO AN ERROR CALL AND CONTROL IS RETURNED TO
25873: # THE CMPIL PROCEDURE AFTER RESETTING THE STACK POINTER.
25874: #
25875: # IF THE ERROR OCCURS AFTER THE END LINE, CONTROL RETURNS
25876: # IN A SLIGHTLY DIFFERENT MANNER TO ENSURE PROPER CLEANUP.
25877: #
25878: err01: movl cmpxs,sp # reset stack pointer
25879: #ssl cmpss # restore s-r stack ptr for cmpil
25880: tstl errsp # jump if error suppress flag set
25881: beqlu 0f
25882: jmp err03
25883: 0:
25884: movl erich,erlst # set flag for listr
25885: jsb listr # list line
25886: jsb prtis # terminate listing
25887: clrl erlst # clear listr flag
25888: movl scnse,r6 # load scan element offset
25889: tstl r6 # skip if not set
25890: beqlu err02
25891: movl r6,r7 # loop counter
25892: incl r6 # increase for ch$ex
25893: jsb alocs # string block for error flag
25894: movl r9,r6 # remember string ptr
25895: movab cfp$f(r9),r9 # ready for character storing
25896: movl r$cim,r10 # point to bad statement
25897: movab cfp$f(r10),r10 # ready to get chars
25898: #
25899: # LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS
25900: #
25901: erra1: movzbl (r10)+,r8 # get next char
25902: cmpl r8,$ch$ht # skip if tab
25903: beqlu erra2
25904: movl $ch$bl,r8 # get a blank
25905: #page
25906: #
25907: # MERGE TO STORE BLANK OR TAB IN ERROR LINE
25908: #
25909: erra2: movb r8,(r9)+ # store char
25910: sobgtr r7,erra1 # loop
25911: movl $ch$ex,r10 # exclamation mark
25912: movb r10,(r9) # store at end of error line
25913: #csc r9 # end of sch loop
25914: movl $stnpd,profs # allow for statement number
25915: movl r6,r9 # point to error line
25916: jsb prtst # print error line
25917: #
25918: # HERE AFTER PLACING ERROR FLAG AS REQUIRED
25919: #
25920: err02: jsb ermsg # generate flag and error message
25921: addl2 $num03,lstlc # bump page ctr for blank, error, blk
25922: clrl r9 # in case of fatal error
25923: cmpl errft,$num03 # pack up if several fatals
25924: blssu 0f
25925: jmp stopr
25926: 0:
25927: #
25928: # COUNT ERROR, INHIBIT EXECUTION IF REQUIRED
25929: #
25930: incl cmerc # bump error count
25931: addl2 cswer,noxeq # inhibit xeq if -noerrors
25932: cmpl stage,$stgic # special return if after end line
25933: beqlu 0f
25934: jmp cmp10
25935: 0:
25936: #page
25937: #
25938: # LOOP TO SCAN TO END OF STATEMENT
25939: #
25940: err03: movl r$cim,r9 # point to start of image
25941: movab cfp$f(r9),r9 # point to first char
25942: movzbl (r9),r9 # get first char
25943: cmpl r9,$ch$mn # jump if error in control card
25944: bnequ 0f
25945: jmp cmpce
25946: 0:
25947: clrl scnrs # clear rescan flag
25948: movl sp,errsp # set error suppress flag
25949: jsb scane # scan next element
25950: cmpl r10,$t$smc # loop back if not statement end
25951: beqlu 0f
25952: jmp err03
25953: 0:
25954: clrl errsp # clear error suppress flag
25955: #
25956: # GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL
25957: #
25958: movl $4*cdcod,cwcof # reset offset in ccblk
25959: movl $ocer$,r6 # load compile error call
25960: jsb cdwrd # generate it
25961: movl cwcof,4*cmsoc(sp)# set success fill in offset
25962: movl sp,4*cmffc(sp) # set failure fill in flag
25963: jsb cdwrd # generate succ. fill in word
25964: jmp cmpse # merge to generate error as cdfal
25965: #
25966: # ERROR DURING EXECUTE TIME COMPILE OR EXPRESSION EVALUATIO
25967: #
25968: # EXECUTE TIME COMPILATION IS INITIATED THROUGH GTCOD OR
25969: # GTEXP WHICH ARE CALLED BY COMPILE, CODE OR EVAL.
25970: # BEFORE CAUSING STATEMENT FAILURE THROUGH EXFAL IT IS
25971: # HELPFUL TO SET KEYWORD ERRTEXT AND FOR GENERALITY
25972: # THESE ERRORS MAY BE HANDLED BY THE SETEXIT MECHANISM.
25973: #
25974: err04: clrl r$ccb # forget garbage code block
25975: #ssl iniss # restore main prog s-r stack ptr
25976: jsb ertex # get fail message text
25977: subl2 $4,sp # ensure stack ok on loop start
25978: #
25979: # POP STACK UNTIL FIND FLPTR FOR MOST DEEPLY NESTED PROG.
25980: # DEFINED FUNCTION CALL OR CALL OF EVAL / CODE.
25981: #
25982: erra4: addl2 $4,sp # pop stack
25983: cmpl sp,flprt # jump if prog defined fn call found
25984: beqlu errc4
25985: cmpl sp,gtcef # loop if not eval or code call yet
25986: bnequ erra4
25987: movl $stgxt,stage # re-set stage for execute
25988: movl r$gtc,r$cod # recover code ptr
25989: movl sp,flptr # restore fail pointer
25990: clrl r$cim # forget possible image
25991: #
25992: # TEST ERRLIMIT
25993: #
25994: errb4: tstl kverl # jump if errlimit non-zero
25995: bnequ err07
25996: jmp exfal # fail
25997: #
25998: # RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING
25999: #
26000: errc4: movl flptr,sp # restore stack from flptr
26001: jmp errb4 # merge
26002: #page
26003: #
26004: # ERROR AT EXECUTE TIME.
26005: #
26006: # THE ACTION TAKEN ON AN ERROR IS AS FOLLOWS.
26007: #
26008: # IF ERRLIMIT KEYWORD IS ZERO, AN ABORT IS SIGNALLED,
26009: # SEE CODING FOR SYSTEM LABEL ABORT AT L$ABO.
26010: #
26011: # OTHERWISE, ERRLIMIT IS DECREMENTED AND AN ERRTYPE TRACE
26012: # GENERATED IF REQUIRED. CONTROL RETURNS EITHER VIA A JUMP
26013: # TO CONTINUE (TO TAKE THE FAILURE EXIT) OR A SPECIFIED
26014: # SETEXIT TRAP IS EXECUTED AND CONTROL PASSES TO THE TRAP.
26015: # IF 3 OR MORE FATAL ERRORS OCCUR AN ABORT IS SIGNALLED
26016: # REGARDLESS OF ERRLIMIT AND SETEXIT - LOOPING IS ALL TOO
26017: # PROBABLE OTHERWISE. FATAL ERRORS INCLUDE STACK OVERFLOW
26018: # AND EXCEEDING STLIMIT.
26019: #
26020: err05: #ssl iniss # restore main prog s-r stack ptr
26021: tstl dmvch # jump if in mid-dump
26022: bnequ err08
26023: #
26024: # MERGE HERE FROM ERR08
26025: #
26026: err06: tstl kverl # abort if errlimit is zero
26027: bnequ 0f
26028: jmp labo1
26029: 0:
26030: jsb ertex # get fail message text
26031: #
26032: # MERGE FROM ERR04
26033: #
26034: err07: cmpl errft,$num03 # abort if too many fatal errors
26035: blssu 0f
26036: jmp labo1
26037: 0:
26038: decl kverl # decrement errlimit
26039: movl r$ert,r10 # load errtype trace pointer
26040: jsb ktrex # generate errtype trace if required
26041: movl r$cod,r$cnt # set cdblk ptr for continuation
26042: movl flptr,r9 # set ptr to failure offset
26043: movl (r9),stxof # save failure offset for continue
26044: movl r$sxc,r9 # load setexit cdblk pointer
26045: tstl r9 # continue if no setexit trap
26046: bnequ 0f
26047: jmp lcnt1
26048: 0:
26049: clrl r$sxc # else reset trap
26050: movl $nulls,stxvr # reset setexit arg to null
26051: movl (r9),r10 # load ptr to code block routine
26052: movl r10,r11 # execute first trap statement
26053: jmp (r11)
26054: #
26055: # INTERRUPTED PARTLY THROUGH A DUMP WHILST STORE IS IN A
26056: # MESS SO DO A TIDY UP OPERATION. SEE DUMPR FOR DETAILS.
26057: #
26058: err08: movl dmvch,r9 # chain head for affected vrblks
26059: tstl r9 # done if zero
26060: beqlu err06
26061: movl (r9),dmvch # set next link as chain head
26062: jsb setvr # restore vrget field
26063: jmp err08 # loop through chain
26064: #title s p i t b o l -- here endeth the code
26065: #
26066: # END OF ASSEMBLY
26067: #
26068: #end # end macro-spitbol assembly
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.