![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to spitv35.serr 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.serr CVS log | Up to [Research Unix] / researchv10no / cmd / spitbol |
1.1 root 1: #title s p i t b o l - revision history
2: #page
3: # R E V I S I O N H I S T O R Y
4: # -------------------------------
5: #
6: #
7: # VERSION 3.5B (FEB 81... - SGD PATCHES)
8: # -----------------------------------
9: #
10: # SGD03 - ADDITION OF .CNCI AND SYSCI (INT->STRING
11: # SYSTEM ROUTINE OPTION)
12: # SGD04 - (06-MAY-1981) MODIFIED INILN TO 132
13: # SGD05 - (13-MAY-1981) INSERTED MISSING WTB AFTER SYSMM
14: # CALLS
15: # SGD06 - (25-MAY-1981) MERGED IN PROFILER PATCHES
16: # (NOT MARKED)
17: # SGD07 - (25-MAY-1981) MUCHO PATCHES TO PROFILER (MARKED,
18: # BUT BEST JUST TO EXTRACT ENMASSE)
19: # SGD08 - (25-MAY-1981) USE STRING LENGTH IN HASHS
20: # SGD09 - (25-MAY-1981) FIXED SERIOUS PARSER PROBLEM
21: # RELATING TO (X Y) ON LINE BEING VIEWED AS PATTERN
22: # MATCH. FIXED BY ADDITION OF NEW CMTYP VALUE
23: # C$CNP (CONCATENATION - NOT PATTERN MATCH)
24: # SGD10 - (01-AUG-1981) FIXED EXIT(N) RESPECIFICATION CODE
25: # TO PROPERLY OBSERVE HEADER SEMANTICS ON RETURN.
26: # SGD11 - (07-AUG-1981) BYPASS PRTPG CALL AT INITIALIZATION
27: # FOLLOWING COMPILATION IF NO OUTPUT GENERATED.
28: # THIS PREVENTS OUTPUT FILES CONSISTING OF THE
29: # HEADERS AND A FEW BLANK LINES WHEN THERE IS NO
30: # SOURCE LISTING AND NO COMPILATION STATS.
31: # ALSO FIX TIMSX INITIALIZATION IN SAME CODE.
32: # SGD12 - (17-AUG-1981) B$EFC CODE DID NOT CHECK FOR
33: # UNCONVERTED RESULT RETURNING NULL STRING. FIXED.
34: # SGDBF - ( NOV-1981) ADDED BUFFER TYPE AND SYMBOL CNBF
35: # SGD13 - (03-MAR-1982) LOAD PFVBL FIELD IN RETRN FOR
36: # RETURN TRACING. THIS WAS CAUSING BUG ON RETURN
37: # TRACES THAT TRIED TO ACCESS THE VARIABLE NAME
38: # SGD14 - ADDED CHAR FUNCTION. CHAR(N) RETURNS NTH
39: # CHARACTER OF HOST MACHINE CHARACTER SET.
40: # NOT CONDITIONALIZED OR MARKED.
41: # SGD15 - FIXED PROBLEM RELATING TO COMPILATION OF GOTO
42: # FIELDS CONTAINING SMALL INTEGERS (IN CONST SEC).
43: #
44: # REG01 - (XX-AUG-82)
45: # ADDED CFP$U TO EASE TRANSLATION ON SMALLER
46: # SYSTEMS - CONDITIONAL .CUCF
47: # ADDED LOWER CASE SUPPORT - CONDITIONAL .CULC
48: # ADDED SET I/O FUNCTION - CONDITIONAL .CUST
49: #
50: # REG02 - (XX-SEP-82)
51: # CHANGED INILN AND AND INILS TO 258
52: #
53: # REG03 - (XX-OCT-82)
54: # CONDITIONALIZED THE PAGE EJECT AFTER CALL TO SYSBX
55: # AND ADDED ANOTHER BEFORE CALL TO SYSBX, SO THAT,
56: # IF DESIRED BY THE IMPLEMENTOR, STANDARD OUTPUT
57: # WILL REFLECT ASSIGNMENTS MADE BY EXECUTING PROGRAM
58: # ONLY. CONDITIONAL .CUEJ CONTROLS - IF DEFINED
59: # EJECT IS BEFORE CALL TO SYSBX.
60: #
61: # REG04 - (XX-NOV-82)
62: # FIXED DIFFICULTIES WITH LISTINGS DURING EXECUTION
63: # WHEN NO LISTING GENERATED DURING COMPILATION.
64: #
65: # -LIST TO CODE() CAUSED BOMB. FIX IS TO RESET
66: # R$TTL AND R$STL TO NULLS NOT 0 AFTER COMPILATION.
67: # (LISTR AND LISTT EXPECT NULLS)
68: #
69: # WHEN LISTING AND STATISTICS ROUTED TO DIFFERENT
70: # FILE THAN EXECUTION OUTPUT, ERROR MESSAGE IS SENT
71: # TO EXECUTION OUTPUT (AND GETS SEPARATED FROM
72: # ... IN STATEMENT ... MSG). LABO1 CALLS SYSAX AND
73: # STOPR DOES NOT CALL SYSAX IF ENTERED FROM LABO1.
74: #
75: # REG05 - (XX-NOV-82)
76: # PREVENT CLEAR() FROM CLOBBERING PROTECTED VARIABLES
77: # AT LABEL SCLR5.
78: #
79: # REG06 - (XX-NOV-82)
80: # FIXED GTEXP FROM ACCEPTING TRAILING SEMICOLON OR
81: # COLON. NOT LEGAL WAY TO END AN EXPRESSION.
82: #
83: # VERSION 3.5A (OCT 79 - SGD PATCHES)
84: # -----------------------------------
85: #
86: # SGD01 - PATCH IN ASIGN TO FIX MULTIPLE TRAP BLOCK PROBLEM
87: # (ASG10+2)
88: # SGD02 - PATCH IN GTARR TO FIX NULL CONVERT (GTAR9+0)
89: #
90: #title s p i t b o l -- basic information
91: #page
92: #
93: # GENERAL STRUCTURE
94: # -----------------
95: #
96: # THIS PROGRAM IS A TRANSLATOR FOR A VERSION OF THE SNOBOL4
97: # PROGRAMMING LANGUAGE. LANGUAGE DETAILS ARE CONTAINED IN
98: # THE MANUAL MACRO SPITBOL BY DEWAR AND MCCANN, TECHNICAL
99: # REPORT 90, UNIVERSITY OF LEEDS 1976. THE LANGUAGE
100: # IS IDENTICAL TO THAT IMPLEMENTED BY THE BTL TRANSLATOR
101: # (R. E. GRISWOLD ET AL.) WITH THE FOLLOWING EXCEPTIONS.
102: #
103: # 1) REDEFINITION OF STANDARD SYSTEM FUNCTIONS AND
104: # OPERATORS IS NOT PERMITTED.
105: #
106: # 2) THE VALUE FUNCTION IS NOT PROVIDED.
107: #
108: # 3) ACCESS TRACING IS PROVIDED IN ADDITION TO THE
109: # OTHER STANDARD TRACE MODES.
110: #
111: # 4) THE KEYWORD STFCOUNT IS NOT PROVIDED.
112: #
113: # 5) THE KEYWORD FULLSCAN IS NOT PROVIDED AND ALL PATTERN
114: # MATCHING TAKES PLACE IN FULLSCAN MODE (I.E. WITH NO
115: # HEURISTICS APPLIED).
116: #
117: # 6) A SERIES OF EXPRESSIONS SEPARATED BY COMMAS MAY
118: # BE GROUPED WITHIN PARENTHESES TO PROVIDE A SELECTION
119: # CAPABILITY. THE SEMANTICS ARE THAT THE SELECTION
120: # ASSUMES THE VALUE OF THE FIRST EXPRESSION WITHIN IT
121: # WHICH SUCCEEDS AS THEY ARE EVALUATED FROM THE LEFT.
122: # IF NO EXPRESSION SUCCEEDS THE ENTIRE STATEMENT FAILS
123: #
124: # 7) AN EXPLICIT PATTERN MATCHING OPERATOR IS PROVIDED.
125: # THIS IS THE BINARY QUERY (SEE GIMPEL SIGPLAN OCT 74)
126: #
127: # 8) THE ASSIGNMENT OPERATOR IS INTRODUCED AS IN THE
128: # GIMPEL REFERENCE.
129: #
130: # 9) THE EXIT FUNCTION IS PROVIDED FOR GENERATING LOAD
131: # MODULES - CF. GIMPELS SITBOL.
132: #
133: #
134: # THE METHOD USED IN THIS PROGRAM IS TO TRANSLATE THE
135: # SOURCE CODE INTO AN INTERNAL PSEUDO-CODE (SEE FOLLOWING
136: # SECTION). AN INTERPRETOR IS THEN USED TO EXECUTE THIS
137: # GENERATED PSEUDO-CODE. THE NATURE OF THE SNOBOL4 LANGUAGE
138: # IS SUCH THAT THE LATTER TASK IS MUCH MORE COMPLEX THAN
139: # THE ACTUAL TRANSLATION PHASE. ACCORDINGLY, NEARLY ALL THE
140: # CODE IN THE PROGRAM SECTION IS CONCERNED WITH THE ACTUAL
141: # EXECUTION OF THE SNOBOL4 PROGRAM.
142: #page
143: #
144: # INTERPRETIVE CODE FORMAT
145: # ------------------------
146: #
147: # THE INTERPRETIVE PSEUDO-CODE CONSISTS OF A SERIES OF
148: # ADDRESS POINTERS. THE EXACT FORMAT OF THE CODE IS
149: # DESCRIBED IN CONNECTION WITH THE CDBLK FORMAT. THE
150: # PURPOSE OF THIS SECTION IS TO GIVE GENERAL INSIGHT INTO
151: # THE INTERPRETIVE APPROACH INVOLVED.
152: #
153: # THE BASIC FORM OF THE CODE IS RELATED TO REVERSE POLISH.
154: # IN OTHER WORDS, THE OPERANDS PRECEDE THE OPERATORS WHICH
155: # ARE ZERO ADDRESS OPERATORS. THERE ARE SOME EXCEPTIONS TO
156: # THESE RULES, NOTABLY THE UNARY NOT OPERATOR AND THE
157: # SELECTION CONSTRUCTION WHICH CLEARLY REQUIRE ADVANCE
158: # KNOWLEDGE OF THE OPERATOR INVOLVED.
159: #
160: # THE OPERANDS ARE MOVED TO THE TOP OF THE MAIN STACK AND
161: # THE OPERATORS ARE APPLIED TO THE TOP STACK ENTRIES. LIKE
162: # OTHER VERSIONS OF SPITBOL, THIS PROCESSOR DEPENDS ON
163: # KNOWING WHETHER OPERANDS ARE REQUIRED BY NAME OR BY VALUE
164: # AND MOVES THE APPROPRIATE OBJECT TO THE STACK. THUS NO
165: # NAME/VALUE CHECKS ARE INCLUDED IN THE OPERATOR CIRCUITS.
166: #
167: # THE ACTUAL POINTERS IN THE CODE POINT TO A BLOCK WHOSE
168: # FIRST WORD IS THE ADDRESS OF THE INTERPRETOR ROUTINE
169: # TO BE EXECUTED FOR THE CODE WORD.
170: #
171: # IN THE CASE OF OPERATORS, THE POINTER IS TO A WORD WHICH
172: # CONTAINS THE ADDRESS OF THE OPERATOR TO BE EXECUTED. IN
173: # THE CASE OF OPERANDS SUCH AS CONSTANTS, THE POINTER IS TO
174: # THE OPERAND ITSELF. ACCORDINGLY, ALL OPERANDS CONTAIN
175: # A FIELD WHICH POINTS TO THE ROUTINE TO LOAD THE VALUE OF
176: # THE OPERAND ONTO THE STACK. IN THE CASE OF A VARIABLE,
177: # THERE ARE THREE SUCH POINTERS. ONE TO LOAD THE VALUE,
178: # ONE TO STORE THE VALUE AND A THIRD TO JUMP TO THE LABEL.
179: #
180: # THE HANDLING OF FAILURE RETURNS DESERVES SPECIAL COMMENT.
181: # THE LOCATION FLPTR CONTAINS THE POINTER TO THE LOCATION
182: # ON THE MAIN STACK WHICH CONTAINS THE FAILURE RETURN
183: # WHICH IS IN THE FORM OF A BYTE OFFSET IN THE CURRENT
184: # CODE BLOCK (CDBLK OR EXBLK). WHEN A FAILURE OCCURS, THE
185: # STACK IS POPPED AS INDICATED BY THE SETTING OF FLPTR AND
186: # CONTROL IS PASSED TO THE APPROPRIATE LOCATION IN THE
187: # CURRENT CODE BLOCK WITH THE STACK POINTER POINTING TO THE
188: # FAILURE OFFSET ON THE STACK AND FLPTR UNCHANGED.
189: #page
190: #
191: # INTERNAL DATA REPRESENTATIONS
192: # -----------------------------
193: #
194: # REPRESENTATION OF VALUES
195: #
196: # A VALUE IS REPRESENTED BY A POINTER TO A BLOCK WHICH
197: # DESCRIBES THE TYPE AND PARTICULARS OF THE DATA VALUE.
198: # IN GENERAL, A VARIABLE IS A LOCATION CONTAINING SUCH A
199: # POINTER (ALTHOUGH IN THE CASE OF TRACE ASSOCIATIONS THIS
200: # IS MODIFIED, SEE DESCRIPTION OF TRBLK).
201: #
202: # THE FOLLOWING IS A LIST OF POSSIBLE DATATYPES SHOWING THE
203: # TYPE OF BLOCK USED TO HOLD THE VALUE. THE DETAILS OF
204: # EACH BLOCK FORMAT ARE GIVEN LATER.
205: #
206: # DATATYPE BLOCK TYPE
207: # -------- ----------
208: #
209: #
210: # ARRAY ARBLK OR VCBLK
211: #
212: # CODE CDBLK
213: #
214: # EXPRESSION EXBLK OR SEBLK
215: #
216: # INTEGER ICBLK
217: #
218: # NAME NMBLK
219: #
220: # PATTERN P0BLK OR P1BLK OR P2BLK
221: #
222: # REAL RCBLK
223: #
224: # STRING SCBLK
225: #
226: # TABLE TBBLK
227: #
228: # PROGRAM DATATYPE PDBLK
229: #page
230: #
231: # REPRESENTATION OF VARIABLES
232: # ---------------------------
233: #
234: # DURING THE COURSE OF EVALUATING EXPRESSIONS, IT IS
235: # NECESSARY TO GENERATE NAMES OF VARIABLES (FOR EXAMPLE
236: # ON THE LEFT SIDE OF A BINARY EQUALS OPERATOR). THESE ARE
237: # NOT TO BE CONFUSED WITH OBJECTS OF DATATYPE NAME WHICH
238: # ARE IN FACT VALUES.
239: #
240: # FROM A LOGICAL POINT OF VIEW, SUCH NAMES COULD BE SIMPLY
241: # REPRESENTED BY A POINTER TO THE APPROPRIATE VALUE CELL.
242: # HOWEVER IN THE CASE OF ARRAYS AND PROGRAM DEFINED
243: # DATATYPES, THIS WOULD VIOLATE THE RULE THAT THERE MUST BE
244: # NO POINTERS INTO THE MIDDLE OF A BLOCK IN DYNAMIC STORE.
245: # ACCORDINGLY, A NAME IS ALWAYS REPRESENTED BY A BASE AND
246: # OFFSET. THE BASE POINTS TO THE START OF THE BLOCK
247: # CONTAINING THE VARIABLE VALUE AND THE OFFSET IS THE
248: # OFFSET WITHIN THIS BLOCK IN BYTES. THUS THE ADDRESS
249: # OF THE ACTUAL VARIABLE IS DETERMINED BY ADDING THE BASE
250: # AND OFFSET VALUES.
251: #
252: # THE FOLLOWING ARE THE INSTANCES OF VARIABLES REPRESENTED
253: # IN THIS MANNER.
254: #
255: # 1) NATURAL VARIABLE BASE IS PTR TO VRBLK
256: # OFFSET IS *VRVAL
257: #
258: # 2) TABLE ELEMENT BASE IS PTR TO TEBLK
259: # OFFSET IS *TEVAL
260: #
261: # 3) ARRAY ELEMENT BASE IS PTR TO ARBLK
262: # OFFSET IS OFFSET TO ELEMENT
263: #
264: # 4) VECTOR ELEMENT BASE IS PTR TO VCBLK
265: # OFFSET IS OFFSET TO ELEMENT
266: #
267: # 5) PROG DEF DTP BASE IS PTR TO PDBLK
268: # OFFSET IS OFFSET TO FIELD VALUE
269: #
270: # IN ADDITION THERE ARE TWO CASES OF OBJECTS WHICH ARE
271: # LIKE VARIABLES BUT CANNOT BE HANDLED IN THIS MANNER.
272: # THESE ARE CALLED PSEUDO-VARIABLES AND ARE REPRESENTED
273: # WITH A SPECIAL BASE POINTER AS FOLLOWS=
274: #
275: # EXPRESSION VARIABLE PTR TO EVBLK (SEE EVBLK)
276: #
277: # KEYWORD VARIABLE PTR TO KVBLK (SEE KVBLK)
278: #
279: # PSEUDO-VARIABLES ARE HANDLED AS SPECIAL CASES BY THE
280: # ACCESS PROCEDURE (ACESS) AND THE ASSIGNMENT PROCEDURE
281: # (ASIGN). SEE THESE TWO PROCEDURES FOR DETAILS.
282: #page
283: #
284: # ORGANIZATION OF DATA AREA
285: # -------------------------
286: #
287: #
288: # THE DATA AREA IS DIVIDED INTO TWO REGIONS.
289: #
290: # STATIC AREA
291: #
292: # THE STATIC AREA BUILDS UP FROM THE BOTTOM AND CONTAINS
293: # DATA AREAS WHICH ARE ALLOCATED DYNAMICALLY BUT ARE NEVER
294: # DELETED OR MOVED AROUND. THE MACRO-PROGRAM ITSELF
295: # USES THE STATIC AREA FOR THE FOLLOWING.
296: #
297: # 1) ALL VARIABLE BLOCKS (VRBLK).
298: #
299: # 2) THE HASH TABLE FOR VARIABLE BLOCKS.
300: #
301: # 3) MISCELLANEOUS BUFFERS AND WORK AREAS (SEE PROGRAM
302: # INITIALIZATION SECTION).
303: #
304: # IN ADDITION, THE SYSTEM PROCEDURES MAY USE THIS AREA FOR
305: # INPUT/OUTPUT BUFFERS, EXTERNAL FUNCTIONS ETC. SPACE IN
306: # THE STATIC REGION IS ALLOCATED BY CALLING PROCEDURE ALOST
307: #
308: # THE FOLLOWING GLOBAL VARIABLES DEFINE THE CURRENT
309: # LOCATION AND SIZE OF THE STATIC AREA.
310: #
311: # STATB ADDRESS OF START OF STATIC AREA
312: # STATE ADDRESS+1 OF LAST WORD IN AREA.
313: #
314: # THE MINIMUM SIZE OF STATIC IS GIVEN APPROXIMATELY BY
315: # 12 + *E$HNB + *E$STS + SPACE FOR ALPHABET STRING
316: # AND STANDARD PRINT BUFFER.
317: #page
318: #
319: # DYNAMIC AREA
320: #
321: # THE DYNAMIC AREA IS BUILT UPWARDS IN MEMORY AFTER THE
322: # STATIC REGION. DATA IN THIS AREA MUST ALL BE IN STANDARD
323: # BLOCK FORMATS SO THAT IT CAN BE PROCESSED BY THE GARBAGE
324: # COLLECTOR (PROCEDURE GBCOL). GBCOL COMPACTS BLOCKS DOWN
325: # IN THIS REGION AS REQUIRED BY SPACE EXHAUSTION AND CAN
326: # ALSO MOVE ALL BLOCKS UP TO ALLOW FOR EXPANSION OF THE
327: # STATIC REGION.
328: # WITH THE EXCEPTION OF TABLES AND ARRAYS, NO SPITBOL
329: # OBJECT ONCE BUILT IN DYNAMIC MEMORY IS EVER SUBSEQUENTLY
330: # MODIFIED. OBSERVING THIS RULE NECESSITATES A COPYING
331: # ACTION DURING STRING AND PATTERN CONCATENATION.
332: #
333: # GARBAGE COLLECTION IS FUNDAMENTAL TO THE ALLOCATION OF
334: # SPACE FOR VALUES. SPITBOL USES A VERY EFFICIENT GARBAGE
335: # COLLECTOR WHICH INSISTS THAT POINTERS INTO DYNAMIC STORE
336: # SHOULD BE IDENTIFIABLE WITHOUT USE OF BIT TABLES,
337: # MARKER BITS ETC. TO SATISFY THIS REQUIREMENT, DYNAMIC
338: # MEMORY MUST NOT START AT TOO LOW AN ADDRESS AND LENGTHS
339: # OF ARRAYS, TABLES, STRINGS, CODE AND EXPRESSION BLOCKS
340: # MAY NOT EXCEED THE NUMERICAL VALUE OF THE LOWEST DYNAMIC
341: # ADDRESS. TO AVOID EITHER PENALIZING USERS WITH MODEST
342: # REQUIREMENTS OR RESTRICTING THOSE WITH GREATER NEEDS ON
343: # HOST SYSTEMS WHERE DYNAMIC MEMORY IS ALLOCATED IN LOW
344: # ADDRESSES, THE MINIMUM DYNAMIC ADDRESS MAY BE SPECIFIED
345: # SUFFICIENTLY HIGH TO PERMIT ARBITRARILY LARGE SPITBOL
346: # OBJECTS TO BE CREATED ( WITH THE POSSIBILITY IN EXTREME
347: # CASES OF WASTING LARGE AMOUNTS OF MEMORY BELOW THE
348: # START ADDRESS). THIS MINIMUM VALUE IS MADE AVAILABLE
349: # IN VARIABLE MXLEN BY A SYSTEM ROUTINE, SYSMX.
350: # ALTERNATIVELY SYSMX MAY INDICATE THAT A
351: # DEFAULT MAY BE USED IN WHICH DYNAMIC IS PLACED
352: # AT THE LOWEST POSSIBLE ADDRESS FOLLOWING STATIC.
353: #
354: # THE FOLLOWING GLOBAL WORK CELLS DEFINE THE LOCATION AND
355: # LENGTH OF THE DYNAMIC AREA.
356: #
357: # DNAMB START OF DYNAMIC AREA
358: # DNAMP NEXT AVAILABLE LOCATION
359: # DNAME LAST AVAILABLE LOCATION + 1
360: #
361: # DNAMB IS ALWAYS HIGHER THAN STATE SINCE THE ALOST
362: # PROCEDURE MAINTAINS SOME EXPANSION SPACE ABOVE STATE.
363: # *** DNAMB MUST NEVER BE PERMITTED TO HAVE A VALUE LESS
364: # THAN THAT IN MXLEN ***
365: #
366: # SPACE IN THE DYNAMIC REGION IS ALLOCATED BY THE ALLOC
367: # PROCEDURE. THE DYNAMIC REGION MAY BE USED BY SYSTEM
368: # PROCEDURES PROVIDED THAT ALL THE RULES ARE OBEYED.
369: #page
370: #
371: # REGISTER USAGE
372: # --------------
373: #
374: # (CP) CODE POINTER REGISTER. USED TO
375: # HOLD A POINTER TO THE CURRENT
376: # LOCATION IN THE INTERPRETIVE PSEUDO
377: # CODE (I.E. PTR INTO A CDBLK).
378: #
379: # (XL,XR) GENERAL INDEX REGISTERS. USUALLY
380: # USED TO HOLD POINTERS TO BLOCKS IN
381: # DYNAMIC STORAGE. AN IMPORTANT
382: # RESTRICTION IS THAT THE VALUE IN
383: # XL MUST BE COLLECTABLE FOR
384: # A GARBAGE COLLECT CALL. A VALUE
385: # IS COLLECTABLE IF IT EITHER POINTS
386: # OUTSIDE THE DYNAMIC AREA, OR IF IT
387: # POINTS TO THE START OF A BLOCK IN
388: # THE DYNAMIC AREA.
389: #
390: # (XS) STACK POINTER. USED TO POINT TO
391: # THE STACK FRONT. THE STACK MAY
392: # BUILD UP OR DOWN AND IS USED
393: # TO STACK SUBROUTINE RETURN POINTS
394: # AND OTHER RECURSIVELY SAVED DATA.
395: #
396: # (XT) AN ALTERNATIVE NAME FOR XL DURING
397: # ITS USE IN ACCESSING STACKED ITEMS.
398: #
399: # (WA,WB,WC) GENERAL WORK REGISTERS. CANNOT BE
400: # USED FOR INDEXING, BUT MAY HOLD
401: # VARIOUS TYPES OF DATA.
402: #
403: # (IA) USED FOR ALL SIGNED INTEGER
404: # ARITHMETIC, BOTH THAT USED BY THE
405: # TRANSLATOR AND THAT ARISING FROM
406: # USE OF SNOBOL4 ARITHMETIC OPERATORS
407: #
408: # (RA) REAL ACCUMULATOR. USED FOR ALL
409: # FLOATING POINT ARITHMETIC.
410: #page
411: #
412: # SPITBOL CONDITIONAL ASSEMBLY SYMBOLS
413: # ------------------------------------
414: #
415: # IN THE SPITBOL TRANSLATOR, THE FOLLOWING CONDITIONAL
416: # ASSEMBLY SYMBOLS ARE REFERRED TO. TO INCORPORATE THE
417: # FEATURES REFERRED TO, THE MINIMAL SOURCE SHOULD BE
418: # PREFACED BY SUITABLE CONDITIONAL ASSEMBLY SYMBOL
419: # DEFINITIONS.
420: # IN ALL CASES IT IS PERMISSIBLE TO DEFAULT THE DEFINITIONS
421: # IN WHICH CASE THE ADDITIONAL FEATURES WILL BE OMITTED
422: # FROM THE TARGET CODE.
423: #
424: # .CASL DEFINE TO INCLUDE 26 SHIFTED LETTRS
425: # .CAHT DEFINE TO INCLUDE HORIZONTAL TAB
426: # .CAVT DEFINE TO INCLUDE VERTICAL TAB
427: # .CIOD IF DEFINED, DEFAULT DELIMITER IS
428: # NOT USED IN PROCESSING 3RD ARG OF
429: # INPUT() AND OUTPUT()
430: # .CNBT DEFINE TO OMIT BATCH INITIALISATION
431: # .CNCI DEFINE TO ENABLE SYSCI ROUTINE
432: # .CNEX DEFINE TO OMIT EXIT() CODE.
433: # .CNLD DEFINE TO OMIT LOAD() CODE.
434: # .CNPF DEFINE TO OMIT PROFILE STUFF
435: # .CNRA DEFINE TO OMIT ALL REAL ARITHMETIC
436: # .CNSR DEFINE TO OMIT SORT, RSORT
437: # .CSAX DEFINE IF SYSAX IS TO BE CALLED
438: # .CSN6 DEFINE TO PAD STMT NOS TO 6 CHARS
439: # .CSN8 DEFINE TO PAD STMT NOS TO 8 CHARS
440: # .CUCF DEFINE TO INCLUDE CFP$U
441: # .CULC DEFINE TO INCLUDE &CASE (LC NAMES)
442: # .CUST DEFINE TO INCLUDE SET() CODE
443: #title s p i t b o l -- procedures section
444: #
445: # THIS SECTION STARTS WITH DESCRIPTIONS OF THE OPERATING
446: # SYSTEM DEPENDENT PROCEDURES WHICH ARE USED BY THE SPITBOL
447: # TRANSLATOR. ALL SUCH PROCEDURES HAVE FIVE LETTER NAMES
448: # BEGINNING WITH SYS. THEY ARE LISTED IN ALPHABETICAL
449: # ORDER.
450: # ALL PROCEDURES HAVE A SPECIFICATION CONSISTING OF A
451: # MODEL CALL, PRECEDED BY A POSSIBLY EMPTY LIST OF REGISTER
452: # CONTENTS GIVING PARAMETERS AVAILABLE TO THE PROCEDURE AND
453: # FOLLOWED BY A POSSIBLY EMPTY LIST OF REGISTER CONTENTS
454: # REQUIRED ON RETURN FROM THE CALL OR WHICH MAY HAVE HAD
455: # THEIR CONTENTS DESTROYED. ONLY THOSE REGISTERS EXPLICITLY
456: # MENTIONED IN THE LIST AFTER THE CALL MAY HAVE THEIR
457: # VALUES CHANGED.
458: # THE SEGMENT OF CODE PROVIDING THE EXTERNAL PROCEDURES IS
459: # CONVENIENTLY REFERRED TO AS OSINT (OPERATING SYSTEM
460: # INTERFACE). THE SYSXX PROCEDURES IT CONTAINS PROVIDE
461: # FACILITIES NOT USUALLY AVAILABLE AS PRIMITIVES IN
462: # ASSEMBLY LANGUAGES. FOR PARTICULAR TARGET MACHINES,
463: # IMPLEMENTORS MAY CHOOSE FOR SOME MINIMAL OPCODES WHICH
464: # DO NOT HAVE REASONABLY DIRECT TRANSLATIONS, TO USE CALLS
465: # OF ADDITIONAL PROCEDURES WHICH THEY PROVIDE IN OSINT.
466: # E.G. MWB OR TRC MIGHT BE TRANSLATED AS JSR SYSMB,
467: # JSR SYSTC IN SOME IMPLEMENTATIONS.
468: #
469: # IN THE DESCRIPTIONS, REFERENCE IS MADE TO --BLK
470: # FORMATS (-- = A PAIR OF LETTERS). SEE THE SPITBOL
471: # DEFINITIONS SECTION FOR DETAILED DESCRIPTIONS OF ALL
472: # SUCH BLOCK FORMATS EXCEPT FCBLK FOR WHICH SYSFC SHOULD
473: # BE CONSULTED.
474: #
475: # SECTION 0 CONTAINS INP,INR SPECIFICATIONS OF INTERNAL
476: # PROCEDURES,ROUTINES. THIS GIVES A SINGLE PASS TRANSLATOR
477: # INFORMATION MAKING IT EASY TO GENERATE ALTERNATIVE CALLS
478: # IN THE TRANSLATION OF JSR-S FOR PROCEDURES OF DIFFERENT
479: # TYPES IF THIS PROVES NECESSARY.
480: #
481: #sec # start of procedures section
482: #page
483: #
484: # SYSAX -- AFTER EXECUTION
485: #
486: .globl sysax # define external entry point
487: #
488: # IF THE CONDITIONAL ASSEMBLY SYMBOL .CSAX IS DEFINED,
489: # THIS ROUTINE IS CALLED IMMEDIATELY AFTER EXECUTION AND
490: # BEFORE PRINTING OF EXECUTION STATISTICS OR DUMP OUTPUT.
491: # PURPOSE OF CALL IS FOR IMPLEMENTOR TO DETERMINE AND
492: # IF THE CALL IS NOT REQUIRED IT WILL BE OMITTED IF .CSAX
493: # IS UNDEFINED. IN THIS CASE SYSAX NEED NOT BE CODED.
494: #
495: # JSR SYSAX CALL AFTER EXECUTION
496: #page
497: #
498: # SYSBX -- BEFORE EXECUTION
499: #
500: .globl sysbx # define external entry point
501: #
502: # CALLED AFTER INITIAL SPITBOL COMPILATION AND BEFORE
503: # COMMENCING EXECUTION IN CASE OSINT NEEDS
504: # TO ASSIGN FILES OR PERFORM OTHER NECESSARY SERVICES.
505: # OSINT MAY ALSO CHOOSE TO SEND A MESSAGE TO ONLINE
506: # TERMINAL (IF ANY) INDICATING THAT EXECUTION IS STARTING.
507: #
508: # JSR SYSBX CALL BEFORE EXECUTION STARTS
509: #page
510: #
511: # SYSDC -- DATE CHECK
512: #
513: .globl sysdc # define external entry point
514: #
515: # SYSDC IS CALLED TO CHECK THAT THE EXPIRY DATE FOR A TRIAL
516: # VERSION OF SPITBOL IS UNEXPIRED.
517: #
518: # JSR SYSDC CALL TO CHECK DATE
519: # RETURN ONLY IF DATE IS OK
520: #page
521: #
522: # SYSDM -- DUMP CORE
523: #
524: .globl sysdm # define external entry point
525: #
526: # SYSDM IS CALLED BY A SPITBOL PROGRAM CALL OF DUMP(N) WITH
527: # N GE 3. ITS PURPOSE IS TO PROVIDE A CORE DUMP.
528: # N COULD HOLD AN ENCODING OF THE START ADRS FOR DUMP AND
529: # AMOUNT TO BE DUMPED E.G. N = 256*A + S , S = START ADRS
530: # IN KILOWORDS, A = KILOWORDS TO DUMP
531: #
532: # (XR) PARAMETER N OF CALL DUMP(N)
533: # JSR SYSDM CALL TO ENTER ROUTINE
534: #page
535: #
536: # SYSDT -- GET CURRENT DATE
537: #
538: .globl sysdt # define external entry point
539: #
540: # SYSDT IS USED TO OBTAIN THE CURRENT DATE. THE DATE IS
541: # RETURNED AS A CHARACTER STRING IN ANY FORMAT APPROPRIATE
542: # TO THE OPERATING SYSTEM IN USE. IT MAY ALSO CONTAIN THE
543: # CURRENT TIME OF DAY. SYSDT IS USED TO IMPLEMENT THE
544: # SNOBOL4 FUNCTION DATE.
545: #
546: # JSR SYSDT CALL TO GET DATE
547: # (XL) POINTER TO BLOCK CONTAINING DATE
548: #
549: # THE FORMAT OF THE BLOCK IS LIKE AN SCBLK EXCEPT THAT
550: # THE FIRST WORD NEED NOT BE SET. THE RESULT IS COPIED
551: # INTO SPITBOL DYNAMIC MEMORY ON RETURN.
552: #page
553: #
554: # SYSEF -- EJECT FILE
555: #
556: .globl sysef # define external entry point
557: #
558: # SYSEF IS USED TO WRITE A PAGE EJECT TO A NAMED FILE. IT
559: # MAY ONLY BE USED FOR FILES WHERE THIS CONCEPT MAKES
560: # SENSE. NOTE THAT SYSEF IS NOT NORMALLY USED FOR THE
561: # STANDARD OUTPUT FILE (SEE SYSEP).
562: #
563: # (WA) PTR TO FCBLK OR ZERO
564: # (XR) EJECT ARGUMENT (SCBLK PTR)
565: # JSR SYSEF CALL TO EJECT FILE
566: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST
567: # PPM LOC RETURN HERE IF INAPPROPRIATE FILE
568: # PPM LOC RETURN HERE IF I/O ERROR
569: #page
570: #
571: # SYSEJ -- END OF JOB
572: #
573: .globl sysej # define external entry point
574: #
575: # SYSEJ IS CALLED ONCE AT THE END OF EXECUTION TO
576: # TERMINATE THE RUN. THE SIGNIFICANCE OF THE ABEND AND
577: # CODE VALUES IS SYSTEM DEPENDENT. IN GENERAL, THE CODE
578: # VALUE SHOULD BE MADE AVAILABLE FOR TESTING, AND THE
579: # ABEND VALUE SHOULD CAUSE SOME POST-MORTEM ACTION SUCH AS
580: # A DUMP. NOTE THAT SYSEJ DOES NOT RETURN TO ITS CALLER.
581: # SEE SYSXI FOR DETAILS OF FCBLK CHAIN
582: #
583: # (WA) VALUE OF ABEND KEYWORD
584: # (WB) VALUE OF CODE KEYWORD
585: # (XL) O OR PTR TO HEAD OF FCBLK CHAIN
586: # JSR SYSEJ CALL TO END JOB
587: #
588: # THE FOLLOWING SPECIAL VALUES ARE USED AS CODES IN (WB)
589: # 999 EXECUTION SUPPRESSED
590: # 998 STANDARD OUTPUT FILE FULL OR UNAVAILABLE IN A SYSXI
591: # LOAD MODULE. IN THESE CASES (WA) CONTAINS THE NUMBER
592: # OF THE STATEMENT CAUSING PREMATURE TERMINATION.
593: #page
594: #
595: # SYSEM -- GET ERROR MESSAGE TEXT
596: #
597: .globl sysem # define external entry point
598: #
599: # SYSEM IS USED TO OBTAIN THE TEXT OF ERR, ERB CALLS IN THE
600: # SOURCE PROGRAM GIVEN THE ERROR CODE NUMBER. IT IS ALLOWED
601: # TO RETURN A NULL STRING IF THIS FACILITY IS UNAVAILABLE.
602: #
603: # (WA) ERROR CODE NUMBER
604: # JSR SYSEM CALL TO GET TEXT
605: # (XR) TEXT OF MESSAGE
606: #
607: # THE RETURNED VALUE IS A POINTER TO A BLOCK IN SCBLK
608: # FORMAT EXCEPT THAT THE FIRST WORD NEED NOT BE SET. THE
609: # STRING IS COPIED INTO DYNAMIC MEMORY ON RETURN.
610: # IF THE NULL STRING IS RETURNED EITHER BECAUSE SYSEM DOES
611: # NOT PROVIDE ERROR MESSAGE TEXTS OR BECAUSE WA IS OUT OF
612: # RANGE, SPITBOL WILL PRINT THE STRING STORED IN ERRTEXT
613: # KEYWORD.
614: #page
615: #
616: # SYSEN -- ENDFILE
617: #
618: .globl sysen # define external entry point
619: #
620: # SYSEN IS USED TO IMPLEMENT THE SNOBOL4 FUNCTION ENDFILE.
621: # THE MEANING IS SYSTEM DEPENDENT. IN GENERAL, ENDFILE
622: # IMPLIES THAT NO FURTHER I/O OPERATIONS WILL BE PERFORMED,
623: # BUT DOES NOT GUARANTEE THIS TO BE THE CASE. THE FILE
624: # SHOULD BE CLOSED AFTER THE CALL, A SUBSEQUENT READ
625: # OR WRITE MAY REOPEN THE FILE AT THE START OR IT MAY BE
626: # NECESSARY TO REOPEN THE FILE VIA SYSIO.
627: #
628: # (WA) PTR TO FCBLK OR ZERO
629: # (XR) ENDFILE ARGUMENT (SCBLK PTR)
630: # JSR SYSEN CALL TO ENDFILE
631: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST
632: # PPM LOC RETURN HERE IF ENDFILE NOT ALLOWED
633: # PPM LOC RETURN HERE IF I/O ERROR
634: # (WA,WB) DESTROYED
635: #
636: # THE SECOND ERROR RETURN IS USED FOR FILES FOR WHICH
637: # ENDFILE IS NOT PERMITTED. FOR EXAMPLE, IT MAY BE EXPECTED
638: # THAT THE STANDARD INPUT AND OUTPUT FILES ARE IN THIS
639: # CATEGORY.
640: #page
641: #
642: # SYSEP -- EJECT PRINTER PAGE
643: #
644: .globl sysep # define external entry point
645: #
646: # SYSEP IS CALLED TO PERFORM A PAGE EJECT ON THE STANDARD
647: # PRINTER OUTPUT FILE (CORRESPONDING TO SYSPR OUTPUT).
648: #
649: # JSR SYSEP CALL TO EJECT PRINTER OUTPUT
650: #page
651: #
652: # SYSEX -- CALL EXTERNAL FUNCTION
653: #
654: .globl sysex # define external entry point
655: #
656: # SYSEX IS CALLED TO PASS CONTROL TO AN EXTERNAL FUNCTION
657: # PREVIOUSLY LOADED WITH A CALL TO SYSLD.
658: #
659: # (XS) POINTER TO ARGUMENTS ON STACK
660: # (XL) POINTER TO CONTROL BLOCK (EFBLK)
661: # (WA) NUMBER OF ARGUMENTS ON STACK
662: # JSR SYSEX CALL TO PASS CONTROL TO FUNCTION
663: # PPM LOC RETURN HERE IF FUNCTION CALL FAILS
664: # (XS) POPPED PAST ARGUMENTS
665: # (XR) RESULT RETURNED
666: #
667: # THE ARGUMENTS ARE STORED ON THE STACK WITH
668: # THE LAST ARGUMENT AT 0(XS). ON RETURN, XS
669: # IS POPPED PAST THE ARGUMENTS.
670: #
671: # THE FORM OF THE ARGUMENTS AS PASSED IS THAT USED IN THE
672: # SPITBOL TRANSLATOR (SEE DEFINITIONS AND DATA STRUCTURES
673: # SECTION). THE CONTROL BLOCK FORMAT IS ALSO DESCRIBED
674: # (UNDER EFBLK) IN THIS SECTION.
675: #
676: # THERE ARE TWO WAYS OF RETURNING A RESULT.
677: #
678: # 1) RETURN A POINTER TO A BLOCK IN DYNAMIC STORAGE. THIS
679: # BLOCK MUST BE IN EXACTLY CORRECT FORMAT, INCLUDING
680: # THE FIRST WORD. ONLY FUNCTIONS WRITTEN WITH INTIMATE
681: # KNOWLEDGE OF THE SYSTEM WILL RETURN IN THIS WAY.
682: #
683: # 2) STRING, INTEGER AND REAL RESULTS MAY BE RETURNED BY
684: # POINTING TO A PSEUDO-BLOCK OUTSIDE DYNAMIC MEMORY.
685: # THIS BLOCK IS IN ICBLK, RCBLK OR SCBLK FORMAT EXCEPT
686: # THAT THE FIRST WORD WILL BE OVERWRITTEN
687: # BY A TYPE WORD ON RETURN AND SO NEED NOT
688: # BE CORRECTLY SET. SUCH A RESULT IS
689: # COPIED INTO MAIN STORAGE BEFORE PROCEEDING.
690: # UNCONVERTED RESULTS MAY SIMILARLY BE RETURNED IN A
691: # PSEUDO-BLOCK WHICH IS IN CORRECT FORMAT INCLUDING
692: # TYPE WORD RECOGNISABLE BY GARBAGE COLLECTOR SINCE
693: # BLOCK IS COPIED INTO DYNAMIC MEMORY.
694: #page
695: #
696: # SYSFC -- FILE CONTROL BLOCK ROUTINE
697: #
698: .globl sysfc # define external entry point
699: #
700: # SEE ALSO SYSIO
701: # INPUT AND OUTPUT HAVE 3 ARGUMENTS REFERRED TO AS SHOWN
702: # INPUT(VARIABLE NAME,FILE ARG1,FILE ARG2)
703: # OUTPUT(VARIABLE NAME,FILE ARG1,FILE ARG2)
704: # FILE ARG1 MAY BE AN INTEGER OR STRING USED TO IDENTIFY
705: # AN I/O CHANNEL. IT IS CONVERTED TO A STRING FOR CHECKING.
706: # THE EXACT SIGNIFICANCE OF FILE ARG2
707: # IS NOT RIGOROUSLY PRESCRIBED BUT TO IMPROVE PORTABILITY,
708: # THE SCHEME DESCRIBED IN THE SPITBOL USER MANUAL
709: # SHOULD BE ADOPTED WHEN POSSIBLE. THE PREFERRED FORM IS
710: # A STRING $F$,R$R$,C$C$,I$I$,...,Z$Z$ WHERE
711: # $F$ IS AN OPTIONAL FILE NAME WHICH IS PLACED FIRST.
712: # REMAINING ITEMS MAY BE OMITTED OR INCLUDED IN ANY ORDER.
713: # $R$ IS MAXIMUM RECORD LENGTH
714: # $C$ IS A CARRIAGE CONTROL CHARACTER OR CHARACTER STRING
715: # $I$ IS SOME FORM OF CHANNEL IDENTIFICATION USED IN THE
716: # ABSENCE OF $F$ TO ASSOCIATE THE VARIABLE
717: # WITH A FILE ALLOCATED DYNAMICALLY BY JCL COMMANDS AT
718: # SPITBOL LOAD TIME.
719: # ,...,Z$Z$ ARE ADDITIONAL FIELDS.
720: # IF , (COMMA) CANNOT BE USED AS A DELIMITER, .CIOD
721: # SHOULD BE DEFINED TO INTRODUCE BY CONDITIONAL ASSEMBLY
722: # ANOTHER DELIMITER (SEE
723: # IODEL EQU *
724: # EARLY IN DEFINITIONS SECTION).
725: # SYSFC IS CALLED WHEN A VARIABLE IS INPUT OR OUTPUT
726: # ASSOCIATED TO CHECK FILE ARG1 AND FILE ARG2 AND
727: # TO REPORT WHETHER AN FCBLK (FILE CONTROL
728: # BLOCK) IS NECESSARY AND IF SO WHAT SIZE IT SHOULD BE.
729: # THIS MAKES IT POSSIBLE FOR SPITBOL RATHER THAN OSINT TO
730: # ALLOCATE SUCH A BLOCK IN DYNAMIC MEMORY IF REQUIRED
731: # OR ALTERNATIVELY IN STATIC MEMORY.
732: # THE SIGNIFICANCE OF AN FCBLK , IF ONE IS REQUESTED, IS
733: # ENTIRELY UP TO THE SYSTEM INTERFACE. THE ONLY RESTRICTION
734: # IS THAT IF THE FCBLK SHOULD APPEAR TO LIE IN DYNAMIC
735: # MEMORY , POINTERS TO IT SHOULD BE PROPER POINTERS TO
736: # THE START OF A RECOGNISABLE AND GARBAGE COLLECTABLE
737: # BLOCK (THIS CONDITION WILL BE MET IF SYSFC REQUESTS
738: # SPITBOL TO PROVIDE AN FCBLK).
739: # AN OPTION IS PROVIDED FOR OSINT TO RETURN A POINTER IN
740: # XL TO AN FCBLK WHICH IT PRIVATELY ALLOCATED. THIS PTR
741: # WILL BE MADE AVAILABLE WHEN I/O OCCURS LATER.
742: # PRIVATE FCBLKS MAY HAVE ARBITRARY CONTENTS AND SPITBOL
743: # STORES NOTHING IN THEM.
744: #page
745: # THE REQUESTED SIZE FOR AN FCBLK IN DYNAMIC MEMORY
746: # SHOULD ALLOW A 2 WORD OVERHEAD FOR BLOCK TYPE AND
747: # LENGTH FIELDS. INFORMATION SUBSEQUENTLY STORED IN THE
748: # REMAINING WORDS MAY BE ARBITRARY IF AN XNBLK (EXTERNAL
749: # NON-RELOCATABLE BLOCK) IS REQUESTED. IF THE REQUEST IS
750: # FOR AN XRBLK (EXTERNAL RELOCATABLE BLOCK) THE
751: # CONTENTS OF WORDS SHOULD BE COLLECTABLE (I.E. ANY
752: # APPARENT POINTERS INTO DYNAMIC SHOULD BE GENUINE BLOCK
753: # POINTERS). THESE RESTRICTIONS DO NOT APPLY IF AN FCBLK
754: # IS ALLOCATED OUTSIDE DYNAMIC OR IS NOT ALLOCATED AT ALL.
755: # IF AN FCBLK IS REQUESTED, ITS FIELDS WILL BE INITIALISED
756: # TO ZERO BEFORE ENTRY TO SYSIO WITH THE EXCEPTION OF
757: # WORDS 0 AND 1 IN WHICH THE BLOCK TYPE AND LENGTH
758: # FIELDS ARE PLACED FOR FCBLKS IN DYNAMIC MEMORY ONLY.
759: # FOR THE POSSIBLE USE OF SYSEJ AND SYSXI, IF FCBLKS
760: # ARE USED, A CHAIN IS BUILT SO THAT THEY MAY ALL BE
761: # FOUND - SEE SYSXI FOR DETAILS.
762: # IF BOTH FILE ARG1 AND FILE ARG2 ARE NULL, CALLS OF SYSFC
763: # AND SYSIO ARE OMITTED.
764: # IF FILE ARG1 IS NULL (STANDARD INPUT/OUTPUT FILE), SYSFC
765: # IS CALLED TO CHECK NON-NULL FILE ARG2 BUT ANY REQUEST
766: # FOR AN FCBLK WILL BE IGNORED, SINCE SPITBOL HANDLES THE
767: # STANDARD FILES SPECIALLY AND CANNOT READILY KEEP FCBLK
768: # POINTERS FOR THEM.
769: # FILEARG1 IS TYPE CHECKED BY SPITBOL SO FURTHER CHECKING
770: # MAY BE UNNECCESSARY IN MANY IMPLEMENTATIONS.
771: # FILE ARG2 IS PASSED SO THAT SYSFC MAY ANALYSE AND
772: # CHECK IT. HOWEVER TO ASSIST IN THIS, SPITBOL ALSO PASSES
773: # ON THE STACK THE COMPONENTS OF THIS ARGUMENT WITH
774: # FILE NAME, $F$ (OTHERWISE NULL) EXTRACTED AND STACKED
775: # FIRST.
776: # THE OTHER FIELDS, IF ANY, ARE EXTRACTED AS SUBSTRINGS,
777: # POINTERS TO THEM ARE STACKED AND A COUNT OF ALL ITEMS
778: # STACKED IS PLACED IN WC. IF AN FCBLK WAS EARLIER
779: # ALLOCATED AND POINTED TO VIA FILE ARG1, SYSFC IS ALSO
780: # PASSED A POINTER TO THIS FCBLK.
781: #
782: # (XL) FILE ARG1 SCBLK PTR (2ND ARG)
783: # (XR) FILEARG2 (3RD ARG) OR NULL
784: # -(XS)...-(XS) SCBLKS FOR $F$,$R$,$C$,...
785: # (WC) NO. OF STACKED SCBLKS ABOVE
786: # (WA) EXISTING FILE ARG1 FCBLK PTR OR 0
787: # (WB) 0/3 FOR INPUT/OUTPUT ASSOCN
788: # JSR SYSFC CALL TO CHECK NEED FOR FCBLK
789: # PPM LOC INVALID FILE ARGUMENT
790: # (XS) POPPED (WC) TIMES
791: # (WA NON ZERO) BYTE SIZE OF REQUESTED FCBLK
792: # (WA=0,XL NON ZERO) PRIVATE FCBLK PTR IN XL
793: # (WA=XL=0) NO FCBLK WANTED, NO PRIVATE FCBLK
794: # (WC) 0/1/2 REQUEST ALLOC OF XRBLK/XNBLK
795: # /STATIC BLOCK FOR USE AS FCBLK
796: # (WB) DESTROYED
797: #page
798: #
799: # SYSHS -- GIVE ACCESS TO HOST COMPUTER FEATURES
800: #
801: .globl syshs # define external entry point
802: #
803: # PROVIDES MEANS FOR IMPLEMENTING SPECIAL FEATURES
804: # ON DIFFERENT HOST COMPUTERS. THE ONLY DEFINED ENTRY IS
805: # THAT WHERE ALL ARGUMENTS ARE NULL IN WHICH CASE SYSHS
806: # RETURNS AN SCBLK CONTAINING NAME OF COMPUTER,
807: # NAME OF OPERATING SYSTEM AND NAME OF SITE SEPARATED BY
808: # COLONS. THE SCBLK NEED NOT HAVE A CORRECT FIRST FIELD
809: # AS THIS IS SUPPLIED ON COPYING STRING TO DYNAMIC MEMORY.
810: # SPITBOL DOES NO ARGUMENT CHECKING BUT DOES PROVIDE A
811: # SINGLE ERROR RETURN FOR ARGUMENTS CHECKED AS ERRONEOUS
812: # BY OSINT. IT ALSO PROVIDES A SINGLE EXECUTION ERROR
813: # RETURN. IF THESE ARE INADEQUATE, USE MAY BE MADE OF THE
814: # MINIMAL ERROR SECTION DIRECT AS DESCRIBED IN MINIMAL
815: # DOCUMENTATION, SECTION 10.
816: # SEVERAL NON-ERROR RETURNS ARE PROVIDED. THE FIRST
817: # CORRESPONDS TO THE DEFINED ENTRY OR, FOR IMPLEMENTATION
818: # DEFINED ENTRIES, ANY STRING MAY BE RETURNED. THE OTHERS
819: # PERMIT RESPECTIVELY, RETURN A NULL RESULT, RETURN WITH A
820: # RESULT TO BE STACKED WHICH IS POINTED AT BY XR, AND A
821: # RETURN CAUSING SPITBOL STATEMENT FAILURE. IF A RETURNED
822: # RESULT IS IN DYNAMIC MEMORY IT MUST OBEY GARBAGE
823: # COLLECTOR RULES. THE ONLY RESULTS COPIED ON RETURN
824: # ARE STRINGS RETURNED VIA PPM LOC3 RETURN.
825: #
826: # (WA) ARGUMENT 1
827: # (XL) ARGUMENT 2
828: # (XR) ARGUMENT 3
829: # JSR SYSHS CALL TO GET HOST INFORMATION
830: # PPM LOC1 ERRONEOUS ARG
831: # PPM LOC2 EXECUTION ERROR
832: # PPM LOC3 SCBLK PTR IN XL OR 0 IF UNAVAILABLE
833: # PPM LOC4 RETURN A NULL RESULT
834: # PPM LOC5 RETURN RESULT IN XR
835: # PPM LOC6 CAUSE STATEMENT FAILURE
836: #page
837: #
838: # SYSID -- RETURN SYSTEM IDENTIFICATION
839: #
840: .globl sysid # define external entry point
841: #
842: # THIS ROUTINE SHOULD RETURN STRINGS TO HEAD THE STANDARD
843: # PRINTER OUTPUT. THE FIRST STRING WILL BE APPENDED TO
844: # A HEADING LINE OF THE FORM
845: # MACRO SPITBOL VERSION V.V
846: # SUPPLIED BY SPITBOL ITSELF. V.V ARE DIGITS GIVING THE
847: # MAJOR VERSION NUMBER AND GENERALLY AT LEAST A MINOR
848: # VERSION NUMBER RELATING TO OSINT SHOULD BE SUPPLIED TO
849: # GIVE SAY
850: # MACRO SPITBOL VERSION V.V(M.M)
851: # THE SECOND STRING SHOULD IDENTIFY AT LEAST THE MACHINE
852: # AND OPERATING SYSTEM. PREFERABLY IT SHOULD INCLUDE
853: # THE DATE AND TIME OF THE RUN.
854: # OPTIONALLY THE STRINGS MAY INCLUDE SITE NAME OF THE
855: # THE IMPLEMENTOR AND/OR MACHINE ON WHICH RUN TAKES PLACE,
856: # UNIQUE SITE OR COPY NUMBER AND OTHER INFORMATION AS
857: # APPROPRIATE WITHOUT MAKING IT SO LONG AS TO BE A
858: # NUISANCE TO USERS.
859: # THE FIRST WORDS OF THE SCBLKS POINTED AT NEED NOT BE
860: # CORRECTLY SET.
861: #
862: # JSR SYSID CALL FOR SYSTEM IDENTIFICATION
863: # (XR) SCBLK PTR FOR ADDITION TO HEADER
864: # (XL) PTR TO SECOND HEADER SCBLK
865: #page
866: #
867: # SYSIL -- GET INPUT RECORD LENGTH
868: #
869: .globl sysil # define external entry point
870: #
871: # SYSIL IS USED TO GET THE LENGTH OF THE NEXT INPUT RECORD
872: # FROM A FILE PREVIOUSLY INPUT ASSOCIATED WITH A SYSIO
873: # CALL. THE LENGTH RETURNED IS USED TO ESTABLISH A BUFFER
874: # FOR A SUBSEQUENT SYSIN CALL.
875: #
876: # (WA) PTR TO FCBLK OR ZERO
877: # JSR SYSIL CALL TO GET RECORD LENGTH
878: # (WA) LENGTH OR ZERO IF FILE CLOSED
879: #
880: # NO HARM IS DONE IF THE VALUE RETURNED IS TOO LONG SINCE
881: # UNUSED SPACE WILL BE RECLAIMED AFTER THE SYSIN CALL.
882: #
883: # NOTE THAT IT IS THE SYSIL CALL (NOT THE SYSIO CALL) WHICH
884: # CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST
885: # RECORD INPUT FROM THE FILE.
886: #page
887: #
888: # SYSIN -- READ INPUT RECORD
889: #
890: .globl sysin # define external entry point
891: #
892: # SYSIN IS USED TO READ A RECORD FROM THE FILE WHICH WAS
893: # REFERENCED IN A PRIOR CALL TO SYSIL (I.E. THESE CALLS
894: # ALWAYS OCCUR IN PAIRS). THE BUFFER PROVIDED IS AN
895: # SCBLK FOR A STRING OF LENGTH SET FROM THE SYSIL CALL.
896: # IF THE ACTUAL LENGTH READ IS LESS THAN THIS, THE LENGTH
897: # FIELD OF THE SCBLK MUST BE MODIFIED BEFORE RETURNING
898: # UNLESS BUFFER IS RIGHT PADDED WITH ZEROES.
899: # IT IS ALSO PERMISSIBLE TO TAKE ANY OF THE ALTERNATIVE
900: # RETURNS AFTER SCBLK LENGTH HAS BEEN MODIFIED.
901: #
902: # (WA) PTR TO FCBLK OR ZERO
903: # (XR) POINTER TO BUFFER (SCBLK PTR)
904: # JSR SYSIN CALL TO READ RECORD
905: # PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI
906: # PPM LOC RETURN HERE IF I/O ERROR
907: # PPM LOC RETURN HERE IF RECORD FORMAT ERROR
908: # (WA,WB,WC) DESTROYED
909: #page
910: #
911: # SYSIO -- INPUT/OUTPUT FILE ASSOCIATION
912: #
913: .globl sysio # define external entry point
914: #
915: # SEE ALSO SYSFC.
916: # SYSIO IS CALLED IN RESPONSE TO A SNOBOL4 INPUT OR OUTPUT
917: # FUNCTION CALL EXCEPT WHEN FILE ARG1 AND FILE ARG2
918: # ARE BOTH NULL.
919: # ITS CALL ALWAYS FOLLOWS IMMEDIATELY AFTER A CALL
920: # OF SYSFC. IF SYSFC REQUESTED ALLOCATION
921: # OF AN FCBLK, ITS ADDRESS WILL BE IN WA.
922: # FOR INPUT FILES, NON-ZERO VALUES OF $R$ SHOULD BE
923: # COPIED TO WC FOR USE IN ALLOCATING INPUT BUFFERS. IF $R$
924: # IS DEFAULTED OR NOT IMPLEMENTED, WC SHOULD BE ZEROISED.
925: # ONCE A FILE HAS BEEN OPENED, SUBSEQUENT INPUT(),OUTPUT()
926: # CALLS IN WHICH THE SECOND ARGUMENT IS IDENTICAL WITH THAT
927: # IN A PREVIOUS CALL, MERELY ASSOCIATE THE ADDITIONAL
928: # VARIABLE NAME (FIRST ARGUMENT) TO THE FILE AND DO NOT
929: # RESULT IN RE-OPENING THE FILE.
930: # IN SUBSEQUENT ASSOCIATED ACCESSES TO THE FILE A POINTER
931: # TO ANY FCBLK ALLOCATED WILL BE MADE AVAILABLE.
932: #
933: # (XL) FILE ARG1 SCBLK PTR (2ND ARG)
934: # (XR) FILE ARG2 SCBLK PTR (3RD ARG)
935: # (WA) FCBLK PTR (0 IF NONE)
936: # (WB) 0 FOR INPUT, 3 FOR OUTPUT
937: # JSR SYSIO CALL TO ASSOCIATE FILE
938: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST
939: # PPM LOC RETURN IF INPUT/OUTPUT NOT ALLOWED
940: # (XL) FCBLK POINTER (0 IF NONE)
941: # (WC) 0 (FOR DEFAULT) OR MAX RECORD LNGTH
942: # (WA,WB) DESTROYED
943: #
944: # THE SECOND ERROR RETURN IS USED IF THE FILE NAMED EXISTS
945: # BUT INPUT/OUTPUT FROM THE FILE IS NOT ALLOWED. FOR
946: # EXAMPLE, THE STANDARD OUTPUT FILE MAY BE IN THIS CATEGORY
947: # AS REGARDS INPUT ASSOCIATION.
948: #page
949: #
950: # SYSLD -- LOAD EXTERNAL FUNCTION
951: #
952: .globl sysld # define external entry point
953: #
954: # SYSLD IS CALLED IN RESPONSE TO THE USE OF THE SNOBOL4
955: # LOAD FUNCTION. THE NAMED FUNCTION IS LOADED (WHATEVER
956: # THIS MEANS), AND A POINTER IS RETURNED. THE POINTER WILL
957: # BE USED ON SUBSEQUENT CALLS TO THE FUNCTION (SEE SYSEX).
958: #
959: # (XR) POINTER TO FUNCTION NAME (SCBLK)
960: # (XL) POINTER TO LIBRARY NAME (SCBLK)
961: # JSR SYSLD CALL TO LOAD FUNCTION
962: # PPM LOC RETURN HERE IF FUNC DOES NOT EXIST
963: # PPM LOC RETURN HERE IF I/O ERROR
964: # (XR) POINTER TO LOADED CODE
965: #
966: # THE SIGNIFICANCE OF THE POINTER RETURNED IS UP TO THE
967: # SYSTEM INTERFACE ROUTINE. THE ONLY RESTRICTION IS THAT
968: # IF THE POINTER IS WITHIN DYNAMIC STORAGE, IT MUST BE
969: # A PROPER BLOCK POINTER.
970: #page
971: #
972: # SYSMM -- GET MORE MEMORY
973: #
974: .globl sysmm # define external entry point
975: #
976: # SYSMM IS CALLED IN AN ATTEMPT TO ALLOCATE MORE DYNAMIC
977: # MEMORY. THIS MEMORY MUST BE ALLOCATED CONTIGUOUSLY WITH
978: # THE CURRENT DYNAMIC DATA AREA.
979: #
980: # THE AMOUNT ALLOCATED IS UP TO THE SYSTEM TO DECIDE. ANY
981: # VALUE IS ACCEPTABLE INCLUDING ZERO IF ALLOCATION IS
982: # IMPOSSIBLE.
983: #
984: # JSR SYSMM CALL TO GET MORE MEMORY
985: # (XR) NUMBER OF ADDITIONAL WORDS OBTAINED
986: #page
987: #
988: # SYSMX -- SUPPLY MXLEN
989: #
990: .globl sysmx # define external entry point
991: #
992: # BECAUSE OF THE METHOD OF GARBAGE COLLECTION, NO SPITBOL
993: # OBJECT IS ALLOWED TO OCCUPY MORE BYTES OF MEMORY THAN
994: # THE INTEGER GIVING THE LOWEST ADDRESS OF DYNAMIC
995: # (GARBAGE COLLECTABLE) MEMORY. MXLEN IS THE NAME USED TO
996: # REFER TO THIS MAXIMUM LENGTH OF AN OBJECT AND FOR MOST
997: # USERS OF MOST IMPLEMENTATIONS, PROVIDED DYNAMIC MEMORY
998: # STARTS AT AN ADDRESS OF AT LEAST A FEW THOUSAND WORDS,
999: # THERE IS NO PROBLEM.
1000: # IF THE DEFAULT STARTING ADDRESS IS LESS THAN SAY 10000 OR
1001: # 20000, THEN A LOAD TIME OPTION SHOULD BE PROVIDED WHERE A
1002: # USER CAN REQUEST THAT HE BE ABLE TO CREATE LARGER
1003: # OBJECTS. THIS ROUTINE INFORMS SPITBOL OF THIS REQUEST IF
1004: # ANY. THE VALUE RETURNED IS EITHER AN INTEGER
1005: # REPRESENTING THE DESIRED VALUE OF MXLEN (AND HENCE THE
1006: # MINIMUM DYNAMIC STORE ADDRESS WHICH MAY RESULT IN
1007: # NON-USE OF SOME STORE) OR ZERO IF A DEFAULT IS ACCEPTABLE
1008: # IN WHICH MXLEN IS SET TO THE LOWEST ADDRESS ALLOCATED
1009: # TO DYNAMIC STORE BEFORE COMPILATION STARTS.
1010: # IF A NON-ZERO VALUE IS RETURNED, THIS IS USED FOR KEYWORD
1011: # MAXLNGTH. OTHERWISE THE INITIAL LOW ADDRESS OF DYNAMIC
1012: # MEMORY IS USED FOR THIS KEYWORD.
1013: #
1014: # JSR SYSMX CALL TO GET MXLEN
1015: # (WA) EITHER MXLEN OR 0 FOR DEFAULT
1016: #page
1017: #
1018: # SYSOU -- OUTPUT RECORD
1019: #
1020: .globl sysou # define external entry point
1021: #
1022: # SYSOU IS USED TO WRITE A RECORD TO A FILE PREVIOUSLY
1023: # ASSOCIATED WITH A SYSIO CALL.
1024: #
1025: # (WA) PTR TO FCBLK OR ZERO
1026: # (XR) RECORD TO BE WRITTEN (SCBLK)
1027: # JSR SYSOU CALL TO OUTPUT RECORD
1028: # PPM LOC FILE FULL OR NO FILE AFTER SYSXI
1029: # PPM LOC RETURN HERE IF I/O ERROR
1030: # (WA,WB,WC) DESTROYED
1031: #
1032: # NOTE THAT IT IS THE SYSOU CALL (NOT THE SYSIO CALL) WHICH
1033: # CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST
1034: # RECORD OUTPUT TO THE FILE.
1035: #page
1036: #
1037: # SYSPI -- PRINT ON INTERACTIVE CHANNEL
1038: #
1039: .globl syspi # define external entry point
1040: #
1041: # IF SPITBOL IS RUN FROM AN ONLINE TERMINAL, OSINT CAN
1042: # REQUEST THAT MESSAGES SUCH AS COPIES OF COMPILATION
1043: # ERRORS BE SENT TO THE TERMINAL (SEE SYSPP). IF RELEVANT
1044: # REPLY WAS MADE BY SYSPP THEN SYSPI IS CALLED TO SEND SUCH
1045: # MESSAGES TO THE INTERACTIVE CHANNEL.
1046: # SYSPI IS ALSO USED FOR SENDING OUTPUT TO THE TERMINAL
1047: # THROUGH THE SPECIAL VARIABLE NAME, TERMINAL.
1048: #
1049: # (XR) PTR TO LINE BUFFER (SCBLK)
1050: # (WA) LINE LENGTH
1051: # JSR SYSPI CALL TO PRINT LINE
1052: # PPM LOC FAILURE RETURN
1053: # (WA,WB) DESTROYED
1054: #page
1055: #
1056: # SYSPP -- OBTAIN PRINT PARAMETERS
1057: #
1058: .globl syspp # define external entry point
1059: #
1060: # SYSPP IS CALLED ONCE DURING COMPILATION TO OBTAIN
1061: # PARAMETERS REQUIRED FOR CORRECT PRINTED OUTPUT FORMAT
1062: # AND TO SELECT OTHER OPTIONS. IT MAY ALSO BE CALLED AGAIN
1063: # AFTER SYSXI WHEN A LOAD MODULE IS RESUMED. IN THIS
1064: # CASE THE VALUE RETURNED IN WA MAY BE LESS THAN OR EQUAL
1065: # TO THAT RETURNED IN INITIAL CALL BUT MAY NOT BE
1066: # GREATER.
1067: # THE INFORMATION RETURNED IS -
1068: # 1. LINE LENGTH IN CHARS FOR STANDARD PRINT FILE
1069: # 2. NO OF LINES/PAGE. 0 IS PREFERABLE FOR A NON-PAGED
1070: # DEVICE (E.G. ONLINE TERMINAL) IN WHICH CASE LISTING
1071: # PAGE THROWS ARE SUPPRESSED AND PAGE HEADERS
1072: # RESULTING FROM -TITLE,-STITL LINES ARE KEPT SHORT.
1073: # 3. AN INITIAL -NOLIST OPTION TO SUPPRESS LISTING UNLESS
1074: # THE PROGRAM CONTAINS AN EXPLICIT -LIST.
1075: # 4. OPTIONS TO SUPPRESS LISTING OF COMPILATION AND/OR
1076: # EXECUTION STATS (USEFUL FOR ESTABLISHED PROGRAMS) -
1077: # COMBINED WITH 3. GIVES POSSIBILITY OF LISTING
1078: # FILE NEVER BEING OPENED.
1079: # 5. OPTION TO HAVE COPIES OF ERRORS SENT TO AN
1080: # INTERACTIVE CHANNEL IN ADDITION TO STANDARD PRINTER.
1081: # 6. OPTION TO KEEP PAGE HEADERS SHORT (E.G. IF LISTING
1082: # TO AN ONLINE TERMINAL).
1083: # 7. AN OPTION TO CHOOSE EXTENDED OR COMPACT LISTING
1084: # FORMAT. IN THE FORMER A PAGE EJECT AND IN THE LATTER
1085: # A FEW LINE FEEDS PRECEDE THE PRINTING OF EACH
1086: # OF-- LISTING, COMPILATION STATISTICS, EXECUTION
1087: # OUTPUT AND EXECUTION STATISTICS.
1088: # 8. AN OPTION TO SUPPRESS EXECUTION AS THOUGH A
1089: # -NOEXECUTE CARD WERE SUPPLIED.
1090: # 9. AN OPTION TO REQUEST THAT NAME /TERMINAL/ BE PRE-
1091: # ASSOCIATED TO AN ONLINE TERMINAL VIA SYSPI AND SYSRI
1092: # 10. AN INTERMEDIATE (STANDARD) LISTING OPTION REQUIRING
1093: # THAT PAGE EJECTS OCCUR IN SOURCE LISTINGS. REDUNDANT
1094: # IF EXTENDED OPTION CHOSEN BUT PARTIALLY EXTENDS
1095: # COMPACT OPTION.
1096: # 11. OPTION TO SUPPRESS SYSID IDENTIFICATION.
1097: #
1098: # JSR SYSPP CALL TO GET PRINT PARAMETERS
1099: # (WA) PRINT LINE LENGTH IN CHARS
1100: # (WB) NUMBER OF LINES/PAGE
1101: # (WC) BITS VALUE ...JIHGFEDCBA WHERE
1102: # A = 1 TO SEND ERROR COPY TO INT.CH.
1103: # B = 1 MEANS STD PRINTER IS INT. CH.
1104: # C = 1 FOR -NOLIST OPTION
1105: # D = 1 TO SUPPRESS COMPILN. STATS
1106: # E = 1 TO SUPPRESS EXECN. STATS
1107: # F = 1/0 FOR EXTNDED/COMPACT LISTING
1108: # G = 1 FOR -NOEXECUTE
1109: # H = 1 PRE-ASSOCIATE /TERMINAL/
1110: # I = 1 FOR STANDARD LISTING OPTION.
1111: # J = 1 SUPPRESSES LISTING HEADER
1112: #page
1113: #
1114: # SYSPR -- PRINT LINE ON STANDARD OUTPUT FILE
1115: #
1116: .globl syspr # define external entry point
1117: #
1118: # SYSPR IS USED TO PRINT A SINGLE LINE ON THE STANDARD
1119: # OUTPUT FILE.
1120: #
1121: # (XR) POINTER TO LINE BUFFER (SCBLK)
1122: # (WA) LINE LENGTH
1123: # JSR SYSPR CALL TO PRINT LINE
1124: # PPM LOC TOO MUCH O/P OR NO FILE AFTER SYSXI
1125: # (WA,WB) DESTROYED
1126: #
1127: # THE BUFFER POINTED TO IS THE LENGTH OBTAINED FROM THE
1128: # SYSPP CALL AND IS FILLED OUT WITH TRAILING BLANKS. THE
1129: # VALUE IN WA IS THE ACTUAL LINE LENGTH WHICH MAY BE LESS
1130: # THAN THE MAXIMUM LINE LENGTH POSSIBLE. THERE IS NO SPACE
1131: # CONTROL ASSOCIATED WITH THE LINE, ALL LINES ARE PRINTED
1132: # SINGLE SPACED. NOTE THAT NULL LINES (WA=0) ARE POSSIBLE
1133: # IN WHICH CASE A BLANK LINE IS TO BE PRINTED.
1134: #
1135: # THE ERROR EXIT IS USED FOR SYSTEMS WHICH LIMIT THE AMOUNT
1136: # OF PRINTED OUTPUT. IF POSSIBLE, PRINTING SHOULD BE
1137: # PERMITTED AFTER THIS CONDITION HAS BEEN SIGNALLED ONCE TO
1138: # ALLOW FOR DUMP AND OTHER DIAGNOSTIC INFORMATION.
1139: # ASSUMING THIS TO BE POSSIBLE, SPITBOL MAY MAKE MORE SYSPR
1140: # CALLS. IF THE ERROR RETURN OCCURS ANOTHER TIME, EXECUTION
1141: # IS TERMINATED BY A CALL OF SYSEJ WITH ENDING CODE 998.
1142: #page
1143: #
1144: # SYSRD -- READ RECORD FROM STANDARD INPUT FILE
1145: #
1146: .globl sysrd # define external entry point
1147: #
1148: # SYSRD IS USED TO READ A RECORD FROM THE STANDARD INPUT
1149: # FILE. THE BUFFER PROVIDED IS AN SCBLK FOR A STRING THE
1150: # LENGTH OF WHICH IN CHARACTERS IS GIVEN IN WC, THIS
1151: # CORRESPONDING TO THE MAXIMUM LENGTH OF STRING WHICH
1152: # SPITBOL IS PREPARED TO RECEIVE. AT COMPILE TIME IT
1153: # CORRESPONDS TO XXX IN THE MOST RECENT -INXXX CARD
1154: # (DEFAULT 72) AND AT EXECUTION TIME TO THE MOST RECENT
1155: # ,R$R$ (RECORD LENGTH) IN THE THIRD ARG OF AN INPUT()
1156: # STATEMENT FOR THE STANDARD INPUT FILE (DEFAULT 80).
1157: # IF FEWER THAN (WC) CHARACTERS ARE READ, THE LENGTH
1158: # FIELD OF THE SCBLK MUST BE ADJUSTED BEFORE RETURNING
1159: # UNLESS THE BUFFER IS RIGHT PADDED WITH ZEROES.
1160: # IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE RETURN
1161: # AFTER SUCH AN ADJUSTMENT HAS BEEN MADE.
1162: # SPITBOL MAY CONTINUE TO MAKE CALLS AFTER AN ENDFILE
1163: # RETURN SO THIS ROUTINE SHOULD BE PREPARED TO MAKE
1164: # REPEATED ENDFILE RETURNS.
1165: #
1166: # (XR) POINTER TO BUFFER (SCBLK PTR)
1167: # (WC) LENGTH OF BUFFER IN CHARACTERS
1168: # JSR SYSRD CALL TO READ LINE
1169: # PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI
1170: # (WA,WB,WC) DESTROYED
1171: #page
1172: #
1173: # SYSRI -- READ RECORD FROM INTERACTIVE CHANNEL
1174: #
1175: .globl sysri # define external entry point
1176: #
1177: # READS A RECORD FROM ONLINE TERMINAL FOR SPITBOL VARIABLE,
1178: # TERMINAL. IF ONLINE TERMINAL IS UNAVAILABLE THEN CODE THE
1179: # ENDFILE RETURN ONLY.
1180: # THE BUFFER PROVIDED IS OF LENGTH 120 CHARACTERS. SYSRI
1181: # SHOULD REPLACE THE COUNT IN THE SECOND WORD OF THE SCBLK
1182: # BY THE ACTUAL CHARACTER COUNT UNLESS BUFFER IS RIGHT
1183: # PADDED WITH ZEROES.
1184: # IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE
1185: # RETURN AFTER ADJUSTING THE COUNT.
1186: # THE END OF FILE RETURN MAY BE USED IF THIS MAKES
1187: # SENSE ON THE TARGET MACHINE (E.G. IF THERE IS AN
1188: # EOF CHARACTER.)
1189: #
1190: # (XR) PTR TO 120 CHAR BUFFER (SCBLK PTR)
1191: # JSR SYSRI CALL TO READ LINE FROM TERMINAL
1192: # PPM LOC END OF FILE RETURN
1193: # (WA,WB,WC) MAY BE DESTROYED
1194: #page
1195: #
1196: # SYSRW -- REWIND FILE
1197: #
1198: .globl sysrw # define external entry point
1199: #
1200: # SYSRW IS USED TO REWIND A FILE I.E. REPOSITION THE FILE
1201: # AT THE START BEFORE THE FIRST RECORD. THE FILE SHOULD BE
1202: # CLOSED AND THE NEXT READ OR WRITE CALL WILL OPEN THE
1203: # FILE AT THE START.
1204: #
1205: # (WA) PTR TO FCBLK OR ZERO
1206: # (XR) REWIND ARG (SCBLK PTR)
1207: # JSR SYSRW CALL TO REWIND FILE
1208: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST
1209: # PPM LOC RETURN HERE IF REWIND NOT ALLOWED
1210: # PPM LOC RETURN HERE IF I/O ERROR
1211: #page
1212: #
1213: # SYSST -- SET FILE POINTER
1214: #
1215: .globl sysst # define external entry point
1216: #
1217: # SYSST IS CALLED TO CHANGE THE POSITION OF A FILE
1218: # POINTER. THIS IS ACCOMPLISHED IN A SYSTEM DEPENDENT
1219: # MANNER, AND THUS THE 2ND AND 3RD ARGUMENTS ARE PASSED
1220: # UNCONVERTED.
1221: #
1222: # (WA) FCBLK POINTER
1223: # (WB) 2ND ARGUMENT
1224: # (WC) 3RD ARGUMENT
1225: # JSR SYSST CALL TO SET FILE POINTER
1226: # PPM LOC RETURN HERE IF INVALID 2ND ARG
1227: # PPM LOC RETURN HERE IF INVALID 3RD ARG
1228: # PPM LOC RETURN HERE IF FILE DOES NOT EXIST
1229: # PPM LOC RETURN HERE IF SET NOT ALLOWED
1230: # PPM LOC RETURN HERE IF I/O ERROR
1231: #
1232: #page
1233: #
1234: # SYSTM -- GET EXECUTION TIME SO FAR
1235: #
1236: .globl systm # define external entry point
1237: #
1238: # SYSTM IS USED TO OBTAIN THE AMOUNT OF EXECUTION TIME
1239: # USED SO FAR SINCE SPITBOL WAS GIVEN CONTROL. THE UNITS
1240: # ARE DESCRIBED AS MILLISECONDS IN THE SPITBOL OUTPUT, BUT
1241: # THE EXACT MEANING IS SYSTEM DEPENDENT. WHERE APPROPRIATE,
1242: # THIS VALUE SHOULD RELATE TO PROCESSOR RATHER THAN CLOCK
1243: # TIMING VALUES.
1244: #
1245: # JSR SYSTM CALL TO GET TIMER VALUE
1246: # (IA) TIME SO FAR IN MILLISECONDS
1247: #page
1248: #
1249: # SYSTT -- TRACE TOGGLE
1250: #
1251: .globl systt # define external entry point
1252: #
1253: # CALLED BY SPITBOL FUNCTION TRACE() WITH NO ARGS TO
1254: # TOGGLE THE SYSTEM TRACE SWITCH. THIS PERMITS TRACING OF
1255: # LABELS IN SPITBOL CODE TO BE TURNED ON OR OFF.
1256: #
1257: # JSR SYSTT CALL TO TOGGLE TRACE SWITCH
1258: #page
1259: #
1260: # SYSUL -- UNLOAD EXTERNAL FUNCTION
1261: #
1262: .globl sysul # define external entry point
1263: #
1264: # SYSUL IS USED TO UNLOAD A FUNCTION PREVIOUSLY
1265: # LOADED WITH A CALL TO SYSLD.
1266: #
1267: # (XR) PTR TO CONTROL BLOCK (EFBLK)
1268: # JSR SYSUL CALL TO UNLOAD FUNCTION
1269: #
1270: # THE FUNCTION CANNOT BE CALLED FOLLOWING A SYSUL CALL
1271: # UNTIL ANOTHER SYSLD CALL IS MADE FOR THE SAME FUNCTION.
1272: #
1273: # THE EFBLK CONTAINS THE FUNCTION CODE POINTER AND ALSO A
1274: # POINTER TO THE VRBLK CONTAINING THE FUNCTION NAME (SEE
1275: # DEFINITIONS AND DATA STRUCTURES SECTION).
1276: #page
1277: #
1278: # SYSXI -- EXIT TO PRODUCE LOAD MODULE
1279: #
1280: .globl sysxi # define external entry point
1281: #
1282: # WHEN SYSXI IS CALLED, XL CONTAINS EITHER A STRING POINTER
1283: # OR ZERO. IN THE FORMER CASE, THE STRING GIVES THE
1284: # CHARACTER NAME OF A PROGRAM. THE INTENTION IS THAT
1285: # SPITBOL EXECUTION SHOULD BE TERMINATED FORTHWITH AND
1286: # THE NAMED PROGRAM LOADED AND EXECUTED. THIS TYPE OF CHAIN
1287: # EXECUTION IS VERY SYSTEM DEPENDENT AND IMPLEMENTORS MAY
1288: # CHOOSE TO OMIT IT OR FIND IT IMPOSSIBLE TO PROVIDE.
1289: # IF (XL) IS ZERO,IA CONTAINS ONE OF THE FOLLOWING INTEGERS
1290: #
1291: # -1, -2, -3
1292: # CREATE IF POSSIBLE A LOAD MODULE CONTAINING ONLY THE
1293: # IMPURE AREA OF MEMORY WHICH NEEDS TO BE LOADED WITH
1294: # A COMPATIBLE PURE SEGMENT FOR SUBSEQUENT EXECUTIONS.
1295: # VERSION NUMBERS TO CHECK COMPATIBILITY SHOULD BE
1296: # KEPT IN BOTH SEGMENTS AND CHECKED ON LOADING.
1297: # TO ASSIST WITH THIS CHECK, (XR) ON ENTRY IS A
1298: # POINTER TO AN SCBLK CONTAINING THE SPITBOL MAJOR
1299: # VERSION NUMBER V.V (SEE SYSID).
1300: #
1301: # 0 IF POSSIBLE, RETURN CONTROL TO JOB CONTROL
1302: # COMMAND LEVEL. THE EFFECT IF AVAILABLE WILL BE
1303: # SYSTEM DEPENDENT.
1304: #
1305: # +1, +2, +3
1306: # CREATE IF POSSIBLE A LOAD MODULE FROM ALL OF
1307: # MEMORY. IT SHOULD BE POSSIBLE TO LOAD AND EXECUTE
1308: # THIS MODULE DIRECTLY.
1309: #
1310: # IN THE CASE OF SAVED LOAD MODULES, THE STATUS OF OPEN
1311: # FILES IS NOT PRESERVED AND IMPLEMENTORS MAY CHOOSE TO
1312: # OFFER MEANS OF ATTACHING FILES BEFORE EXECUTION OF LOAD
1313: # MODULES STARTS OR LEAVE IT TO THE USER TO INCLUDE
1314: # SUITABLE INPUT(), OUTPUT() CALLS IN HIS PROGRAM.
1315: # SYSXI SHOULD MAKE A NOTE THAT NO I/O CHANNELS,
1316: # INCLUDING STANDARD FILES, HAVE FILES ATTACHED SO THAT
1317: # CALLS OF SYSIN, SYSOU, SYSPR, SYSRD SHOULD FAIL UNLESS
1318: # NEW ASSOCIATIONS ARE MADE FOR THE LOAD MODULE.
1319: # AT LEAST IN THE CASE OF THE STANDARD OUTPUT FILE, IT IS
1320: # RECOMMENDED THAT EITHER THE USER BE REQUIRED TO ATTACH
1321: # A FILE OR THAT A DEFAULT FILE IS ATTACHED, SINCE THE
1322: # PROBLEM OF ERROR MESSAGES GENERATED BY THE LOAD MODULE
1323: # IS OTHERWISE SEVERE. AS A LAST RESORT, IF SPITBOL
1324: # ATTEMPTS TO WRITE TO THE STANDARD OUTPUT FILE AND GETS A
1325: # REPLY INDICATING THAT SUCH OUPUT IS UNACCEPTABLE IT STOPS
1326: # BY USING AN ENTRY TO SYSEJ WITH ENDING CODE 998.
1327: # AS DESCRIBED BELOW, PASSING OF SOME ARGUMENTS MAKES IT
1328: # CLEAR THAT LOAD MODULE WILL USE A STANDARD OUTPUT FILE.
1329: #
1330: # IF USE IS MADE OF FCBLKS FOR I/O ASSOCIATION, SPITBOL
1331: # BUILDS A CHAIN SO THAT THOSE IN USE MAY BE FOUND IN SYSXI
1332: # AND SYSEJ. THE NODES ARE 4 WORDS LONG. THIRD WORD
1333: # CONTAINS LINK TO NEXT NODE OR 0, FOURTH WORD CONTAINS
1334: # FCBLK POINTER.
1335: #page
1336: #
1337: # SYSXI (CONTINUED)
1338: #
1339: # (XL) ZERO OR SCBLK PTR
1340: # (XR) PTR TO V.V SCBLK
1341: # (IA) SIGNED INTEGER ARGUMENT
1342: # (WB) 0 OR PTR TO HEAD OF FCBLK CHAIN
1343: # JSR SYSXI CALL TO EXIT
1344: # PPM LOC REQUESTED ACTION NOT POSSIBLE
1345: # PPM LOC ACTION CAUSED IRRECOVERABLE ERROR
1346: # (REGISTERS) SHOULD BE PRESERVED OVER CALL
1347: #
1348: # LOADING AND RUNNING THE LOAD MODULE OR RETURNING FROM
1349: # JCL COMMAND LEVEL CAUSES EXECUTION TO RESUME AT THE POINT
1350: # AFTER THE ERROR RETURNS WHICH FOLLOW THE CALL OF SYSXI.
1351: # THE VALUE PASSED AS EXIT ARGUMENT IS USED TO INDICATE
1352: # OPTIONS REQUIRED ON RESUMPTION OF LOAD MODULE.
1353: # +1 OR -1 REQUIRE THAT ON RESUMPTION, SYSID AND SYSPP BE
1354: # CALLED AND A HEADING PRINTED ON THE STANDARD OUTPUT FILE.
1355: # +2 OR -2 INDICATE THAT SYSPP WILL BE CALLED BUT NOT SYSID
1356: # AND NO HEADING WILL BE PUT ON STANDARD OUTPUT FILE.
1357: # ABOVE OPTIONS HAVE THE OBVIOUS IMPLICATION THAT A
1358: # STANDARD O/P FILE MUST BE PROVIDED FOR THE LOAD MODULE.
1359: # +3 OR -3 INDICATE CALLS OF NEITHER SYSID NOR SYSPP
1360: # AND NO HEADING WILL BE PLACED ON STANDARD OUTPUT FILE.
1361: # NO RETURN FROM SYSXI IS POSSIBLE IF ANOTHER PROGRAM
1362: # IS LOADED AND ENTERED.
1363: #page
1364: #
1365: # INTRODUCE THE INTERNAL PROCEDURES.
1366: #
1367: .globl acess
1368: .globl acomp
1369: .globl alloc
1370: .globl alobf
1371: .globl alocs
1372: .globl alost
1373: .globl apndb
1374: .globl arith
1375: .globl asign
1376: .globl asinp
1377: .globl blkln
1378: .globl cdgcg
1379: .globl cdgex
1380: .globl cdgnm
1381: .globl cdgvl
1382: .globl cdwrd
1383: .globl cmgen
1384: .globl cmpil
1385: .globl cncrd
1386: .globl copyb
1387: .globl dffnc
1388: .globl dtach
1389: .globl dtype
1390: .globl dumpr
1391: .globl ermsg
1392: .globl ertex
1393: .globl evali
1394: .globl evalp
1395: .globl evals
1396: .globl evalx
1397: .globl exbld
1398: .globl expan
1399: .globl expap
1400: .globl expdm
1401: .globl expop
1402: .globl flstg
1403: .globl gbcol
1404: .globl gbcpf
1405: .globl gtarr
1406: #page
1407: .globl gtcod
1408: .globl gtexp
1409: .globl gtint
1410: .globl gtnum
1411: .globl gtnvr
1412: .globl gtpat
1413: .globl gtrea
1414: .globl gtsmi
1415: .globl gtstg
1416: .globl gtvar
1417: .globl hashs
1418: .globl icbld
1419: .globl ident
1420: .globl inout
1421: .globl insbf
1422: .globl iofcb
1423: .globl ioppf
1424: .globl ioput
1425: .globl ktrex
1426: .globl kwnam
1427: .globl lcomp
1428: .globl listr
1429: .globl listt
1430: .globl nexts
1431: .globl patin
1432: .globl patst
1433: .globl pbild
1434: .globl pconc
1435: .globl pcopy
1436: .globl prflr
1437: .globl prflu
1438: .globl prpar
1439: .globl prtch
1440: .globl prtic
1441: .globl prtis
1442: .globl prtin
1443: .globl prtmi
1444: .globl prtmx
1445: .globl prtnl
1446: .globl prtnm
1447: .globl prtnv
1448: .globl prtpg
1449: .globl prtps
1450: .globl prtsn
1451: .globl prtst
1452: #page
1453: .globl prttr
1454: .globl prtvl
1455: .globl prtvn
1456: .globl rcbld
1457: .globl readr
1458: .globl sbstr
1459: .globl scane
1460: .globl scngf
1461: .globl setvr
1462: .globl sorta
1463: .globl sortc
1464: .globl sortf
1465: .globl sorth
1466: .globl tfind
1467: .globl trace
1468: .globl trbld
1469: .globl trimr
1470: .globl trxeq
1471: .globl xscan
1472: .globl xscni
1473: #
1474: # INTRODUCE THE INTERNAL ROUTINES
1475: #
1476: .globl arref
1477: .globl cfunc
1478: .globl exfal
1479: .globl exint
1480: .globl exits
1481: .globl exixr
1482: .globl exnam
1483: .globl exnul
1484: .globl exrea
1485: .globl exsid
1486: .globl exvnm
1487: .globl failp
1488: .globl flpop
1489: .globl indir
1490: .globl match
1491: .globl retrn
1492: .globl stcov
1493: .globl stmgo
1494: .globl stopr
1495: .globl succp
1496: .globl sysab
1497: .globl systu
1498: #title s p i t b o l -- definitions and data structures
1499: #sec # start of definitions section
1500: #
1501: # DEFINITIONS OF MACHINE PARAMETERS
1502: #
1503: # THE MINIMAL TRANSLATOR SHOULD SUPPLY APPROPRIATE VALUES
1504: # FOR THE PARTICULAR TARGET MACHINE FOR ALL THE
1505: # EQU *
1506: # DEFINITIONS GIVEN AT THE START OF THIS SECTION.
1507: #
1508: .set cfp$a,256 # number of characters in alphabet
1509: #
1510: .set cfp$b,4 # bytes/word addressing factor
1511: #
1512: .set cfp$c,4 # number of characters per word
1513: #
1514: .set cfp$f,8 # offset in bytes to chars in
1515: # SCBLK. SEE SCBLK FORMAT.
1516: #
1517: .set cfp$i,1 # number of words in integer constant
1518: #
1519: .set cfp$m,0x7fffffff# max positive integer in one word
1520: #
1521: .set cfp$n,32 # number of bits in one word
1522: #
1523: # THE FOLLOWING DEFINITIONS REQUIRE THE SUPPLY OF EITHER
1524: # A SINGLE PARAMETER IF REAL ARITHMETIC IS OMITTED OR
1525: # THREE PARAMETERS IF REAL ARITHMETIC IS INCLUDED.
1526: #
1527: #
1528: .set cfp$r,1 # number of words in real constant
1529: #
1530: .set cfp$s,6 # number of sig digs for real output
1531: #
1532: .set cfp$x,2 # max digits in real exponent
1533: #
1534: .set mxdgs,cfp$s+cfp$x# max digits in real number
1535: #
1536: .set nstmx,mxdgs+5 # max space for real (for +0.e+)
1537: #
1538: # THE FOLLOWING DEFINITION FOR CFP$U SUPPLIES A REALISTIC
1539: # UPPER BOUND ON THE SIZE OF THE ALPHABET. CFP$U IS USED
1540: # TO SAVE SPACE IN THE SCANE BSW-IFF-ESW TABLE AND TO EASE
1541: # TRANSLATION STORAGE REQUIREMENTS.
1542: #
1543: .set cfp$u,128 # realistic upper bound on alphabet
1544: #page
1545: #
1546: # ENVIRONMENT PARAMETERS
1547: #
1548: # THE SPITBOL PROGRAM IS ESSENTIALLY INDEPENDENT OF
1549: # THE DEFINITIONS OF THESE PARAMETERS. HOWEVER, THE
1550: # EFFICIENCY OF THE SYSTEM MAY BE AFFECTED. CONSEQUENTLY,
1551: # THESE PARAMETERS MAY REQUIRE TUNING FOR A GIVEN VERSION
1552: # THE VALUES GIVEN IN COMMENTS HAVE BEEN SUCCESSFULLY USED.
1553: #
1554: # E$SRS IS THE NUMBER OF WORDS TO RESERVE AT THE END OF
1555: # STORAGE FOR END OF RUN PROCESSING. IT SHOULD BE
1556: # SET AS SMALL AS POSSIBLE WITHOUT CAUSING MEMORY OVERFLOW
1557: # IN CRITICAL SITUATIONS (E.G. MEMORY OVERFLOW TERMINATION)
1558: # AND SHOULD THUS RESERVE SUFFICIENT SPACE AT LEAST FOR
1559: # AN SCBLK CONTAINING SAY 30 CHARACTERS.
1560: #
1561: .set e$srs,50 # 30 words
1562: #
1563: # E$STS IS THE NUMBER OF WORDS GRABBED IN A CHUNK WHEN
1564: # STORAGE IS ALLOCATED IN THE STATIC REGION. THE MINIMUM
1565: # PERMITTED VALUE IS 256/CFP$B. LARGER VALUES WILL LEAD
1566: # TO INCREASED EFFICIENCY AT THE COST OF WASTING MEMORY.
1567: #
1568: .set e$sts,512 # 500 words
1569: #
1570: # E$CBS IS THE SIZE OF CODE BLOCK ALLOCATED INITIALLY AND
1571: # THE EXPANSION INCREMENT IF OVERFLOW OCCURS. IF THIS VALUE
1572: # IS TOO SMALL OR TOO LARGE, EXCESSIVE GARBAGE COLLECTIONS
1573: # WILL OCCUR DURING COMPILATION AND MEMORY MAY BE LOST
1574: # IN THE CASE OF A TOO LARGE VALUE.
1575: #
1576: .set e$cbs,512 # 500 words
1577: #
1578: # E$HNB IS THE NUMBER OF BUCKET HEADERS IN THE VARIABLE
1579: # HASH TABLE. IT SHOULD ALWAYS BE ODD. LARGER VALUES WILL
1580: # SPEED UP COMPILATION AND INDIRECT REFERENCES AT THE
1581: # EXPENSE OF ADDITIONAL STORAGE FOR THE HASH TABLE ITSELF.
1582: #
1583: .set e$hnb,253 # 127 bucket headers
1584: #
1585: # E$HNW IS THE MAXIMUM NUMBER OF WORDS OF A STRING
1586: # NAME WHICH PARTICIPATE IN THE STRING HASH ALGORITHM.
1587: # LARGER VALUES GIVE A BETTER HASH AT THE EXPENSE OF TAKING
1588: # LONGER TO COMPUTE THE HASH. THERE IS SOME OPTIMAL VALUE.
1589: #
1590: .set e$hnw,3 # 6 words
1591: #
1592: # E$FSP . IF THE AMOUNT OF FREE SPACE LEFT AFTER A GARBAGE
1593: # COLLECTION IS SMALL COMPARED TO THE TOTAL AMOUNT OF SPACE
1594: # IN USE GARBAGE COLLECTOR THRASHING IS LIKELY TO OCCUR AS
1595: # THIS SPACE IS USED UP. E$FSP IS A MEASURE OF THE
1596: # MINIMUM PERCENTAGE OF DYNAMIC MEMORY LEFT AS FREE SPACE
1597: # BEFORE THE SYSTEM ROUTINE SYSMM IS CALLED TO TRY TO
1598: # OBTAIN MORE MEMORY.
1599: #
1600: .set e$fsp,20 # 15 percent
1601: #page
1602: #
1603: # DEFINITIONS OF CODES FOR LETTERS
1604: #
1605: .set ch$la,65 # letter a
1606: .set ch$lb,66 # letter b
1607: .set ch$lc,67 # letter c
1608: .set ch$ld,68 # letter d
1609: .set ch$le,69 # letter e
1610: .set ch$lf,70 # letter f
1611: .set ch$lg,71 # letter g
1612: .set ch$lh,72 # letter h
1613: .set ch$li,73 # letter i
1614: .set ch$lj,74 # letter j
1615: .set ch$lk,75 # letter k
1616: .set ch$ll,76 # letter l
1617: .set ch$lm,77 # letter m
1618: .set ch$ln,78 # letter n
1619: .set ch$lo,79 # letter o
1620: .set ch$lp,80 # letter p
1621: .set ch$lq,81 # letter q
1622: .set ch$lr,82 # letter r
1623: .set ch$ls,83 # letter s
1624: .set ch$lt,84 # letter t
1625: .set ch$lu,85 # letter u
1626: .set ch$lv,86 # letter v
1627: .set ch$lw,87 # letter w
1628: .set ch$lx,88 # letter x
1629: .set ch$ly,89 # letter y
1630: .set ch$l$,90 # letter z
1631: #
1632: # DEFINITIONS OF CODES FOR DIGITS
1633: #
1634: .set ch$d0,48 # digit 0
1635: .set ch$d1,49 # digit 1
1636: .set ch$d2,50 # digit 2
1637: .set ch$d3,51 # digit 3
1638: .set ch$d4,52 # digit 4
1639: .set ch$d5,53 # digit 5
1640: .set ch$d6,54 # digit 6
1641: .set ch$d7,55 # digit 7
1642: .set ch$d8,56 # digit 8
1643: .set ch$d9,57 # digit 9
1644: #page
1645: #
1646: # DEFINITIONS OF CODES FOR SPECIAL CHARACTERS
1647: #
1648: # THE NAMES OF THESE CHARACTERS ARE RELATED TO THEIR
1649: # ORIGINAL REPRESENTATION IN THE EBCDIC SET CORRESPONDING
1650: # TO THE DESCRIPTION IN STANDARD SNOBOL4 MANUALS AND TEXTS.
1651: #
1652: .set ch$am,38 # keyword operator (ampersand)
1653: .set ch$as,42 # multiplication symbol (asterisk)
1654: .set ch$at,64 # cursor position operator (at)
1655: .set ch$bb,60 # left array bracket (less than)
1656: .set ch$bl,32 # blank
1657: .set ch$br,124 # alternation operator (vertical bar)
1658: .set ch$cl,58 # goto symbol (colon)
1659: .set ch$cm,44 # comma
1660: .set ch$dl,36 # indirection operator (dollar)
1661: .set ch$dt,46 # name operator (dot)
1662: .set ch$dq,34 # double quote
1663: .set ch$eq,61 # equal sign
1664: .set ch$ex,33 # exponentiation operator (exclm)
1665: .set ch$mn,45 # minus sign
1666: .set ch$nm,35 # number sign
1667: .set ch$nt,126 # negation operator (not)
1668: .set ch$pc,37 # percent
1669: .set ch$pl,43 # plus sign
1670: .set ch$pp,40 # left parenthesis
1671: .set ch$rb,62 # right array bracket (grtr than)
1672: .set ch$rp,41 # right parenthesis
1673: .set ch$qu,63 # interrogation operator (question)
1674: .set ch$sl,47 # slash
1675: .set ch$sm,59 # semicolon
1676: .set ch$sq,39 # single quote
1677: .set ch$un,95 # special identifier char (underline)
1678: .set ch$ob,91 # opening bracket
1679: .set ch$cb,93 # closing bracket
1680: #page
1681: #
1682: # REMAINING CHARS ARE OPTIONAL ADDITIONS TO THE STANDARDS.
1683: #
1684: # TAB CHARACTERS - SYNTACTICALLY EQUIVALENT TO BLANK
1685: #
1686: .set ch$ht,9 # horizontal tab
1687: #
1688: # LOWER CASE OR SHIFTED CASE ALPHABETIC CHARS
1689: #
1690: .set ch$$a,97 # shifted a
1691: .set ch$$b,98 # shifted b
1692: .set ch$$c,99 # shifted c
1693: .set ch$$d,100 # shifted d
1694: .set ch$$e,101 # shifted e
1695: .set ch$$f,102 # shifted f
1696: .set ch$$g,103 # shifted g
1697: .set ch$$h,104 # shifted h
1698: .set ch$$i,105 # shifted i
1699: .set ch$$j,106 # shifted j
1700: .set ch$$k,107 # shifted k
1701: .set ch$$l,108 # shifted l
1702: .set ch$$m,109 # shifted m
1703: .set ch$$n,110 # shifted n
1704: .set ch$$o,111 # shifted o
1705: .set ch$$p,112 # shifted p
1706: .set ch$$q,113 # shifted q
1707: .set ch$$r,114 # shifted r
1708: .set ch$$s,115 # shifted s
1709: .set ch$$t,116 # shifted t
1710: .set ch$$u,117 # shifted u
1711: .set ch$$v,118 # shifted v
1712: .set ch$$w,119 # shifted w
1713: .set ch$$x,120 # shifted x
1714: .set ch$$y,121 # shifted y
1715: .set ch$$$,122 # shifted z
1716: # IF A DELIMITER OTHER THAN CH$CM MUST BE USED IN
1717: # THE THIRD ARGUMENT OF INPUT(),OUTPUT() THEN .CIOD SHOULD
1718: # BE DEFINED AND A PARAMETER SUPPLIED FOR IODEL.
1719: #
1720: .set iodel,0
1721: #page
1722: #
1723: # DATA BLOCK FORMATS AND DEFINITIONS
1724: #
1725: # THE FOLLOWING SECTIONS DESCRIBE THE DETAILED FORMAT OF
1726: # ALL POSSIBLE DATA BLOCKS IN STATIC AND DYNAMIC MEMORY.
1727: #
1728: # EVERY BLOCK HAS A NAME OF THE FORM XXBLK WHERE XX IS A
1729: # UNIQUE TWO CHARACTER IDENTIFIER. THE FIRST WORD OF EVERY
1730: # BLOCK MUST CONTAIN A POINTER TO A PROGRAM LOCATION IN THE
1731: # INTERPRETOR WHICH IS IMMEDIATELY PRECEDED BY AN ADDRESS
1732: # CONSTANT CONTAINING THE VALUE BL$XX WHERE XX IS THE BLOCK
1733: # IDENTIFIER. THIS PROVIDES A UNIFORM MECHANISM FOR
1734: # DISTINGUISHING BETWEEN THE VARIOUS BLOCK TYPES.
1735: #
1736: # IN SOME CASES, THE CONTENTS OF THE FIRST WORD IS CONSTANT
1737: # FOR A GIVEN BLOCK TYPE AND MERELY SERVES AS A POINTER
1738: # TO THE IDENTIFYING ADDRESS CONSTANT. HOWEVER, IN OTHER
1739: # CASES THERE ARE SEVERAL POSSIBILITIES FOR THE FIRST
1740: # WORD IN WHICH CASE EACH OF THE SEVERAL PROGRAM ENTRY
1741: # POINTS MUST BE PRECEDED BY THE APPROPRIATE CONSTANT.
1742: #
1743: # IN EACH BLOCK, SOME OF THE FIELDS ARE RELOCATABLE. THIS
1744: # MEANS THAT THEY MAY CONTAIN A POINTER TO ANOTHER BLOCK
1745: # IN THE DYNAMIC AREA. (TO BE MORE PRECISE, IF THEY CONTAIN
1746: # A POINTER WITHIN THE DYNAMIC AREA, THEN IT IS A POINTER
1747: # TO A BLOCK). SUCH FIELDS MUST BE MODIFIED BY THE GARBAGE
1748: # COLLECTOR (PROCEDURE GBCOL) WHENEVER BLOCKS ARE COMPACTED
1749: # IN THE DYNAMIC REGION. THE GARBAGE COLLECTOR (ACTUALLY
1750: # PROCEDURE GBCPF) REQUIRES THAT ALL SUCH RELOCATABLE
1751: # FIELDS IN A BLOCK MUST BE CONTIGUOUS.
1752: #page
1753: #
1754: # THE DESCRIPTION FORMAT USES THE FOLLOWING SCHEME.
1755: #
1756: # 1) BLOCK TITLE AND TWO CHARACTER IDENTIFIER
1757: #
1758: # 2) DESCRIPTION OF BASIC USE OF BLOCK AND INDICATION
1759: # OF CIRCUMSTANCES UNDER WHICH IT IS CONSTRUCTED.
1760: #
1761: # 3) PICTURE OF THE BLOCK FORMAT. IN THESE PICTURES LOW
1762: # MEMORY ADDRESSES ARE AT THE TOP OF THE PAGE. FIXED
1763: # LENGTH FIELDS ARE SURROUNDED BY I (LETTER I). FIELDS
1764: # WHICH ARE FIXED LENGTH BUT WHOSE LENGTH IS DEPENDENT
1765: # ON A CONFIGURATION PARAMETER ARE SURROUNDED BY *
1766: # (ASTERISK). VARIABLE LENGTH FIELDS ARE SURROUNDED
1767: # BY / (SLASH).
1768: #
1769: # 4) DEFINITION OF SYMBOLIC OFFSETS TO FIELDS IN
1770: # BLOCK AND OF THE SIZE OF THE BLOCK IF FIXED LENGTH
1771: # OR OF THE SIZE OF THE FIXED LENGTH FIELDS IF THE
1772: # BLOCK IS VARIABLE LENGTH.
1773: # NOTE THAT SOME ROUTINES SUCH AS GBCPF ASSUME
1774: # CERTAIN OFFSETS ARE EQUAL. THE DEFINITIONS
1775: # GIVEN HERE ENFORCE THIS. MAKE CHANGES TO
1776: # THEM ONLY WITH DUE CARE.
1777: #
1778: # DEFINITIONS OF COMMON OFFSETS
1779: #
1780: .set offs1,1
1781: .set offs2,2
1782: .set offs3,3
1783: #
1784: # 5) DETAILED COMMENTS ON THE SIGNIFICANCE AND FORMATS
1785: # OF THE VARIOUS FIELDS.
1786: #
1787: # THE ORDER IS ALPHABETICAL BY IDENTIFICATION CODE.
1788: #page
1789: #
1790: # DEFINITIONS OF BLOCK CODES
1791: #
1792: # THIS TABLE PROVIDES A UNIQUE IDENTIFICATION CODE FOR
1793: # EACH SEPARATE BLOCK TYPE. THE FIRST WORD OF A BLOCK IN
1794: # THE DYNAMIC AREA ALWAYS CONTAINS THE ADDRESS OF A PROGRAM
1795: # ENTRY POINT. THE BLOCK CODE IS USED AS THE ENTRY POINT ID
1796: # THE ORDER OF THESE CODES DICTATES THE ORDER OF THE TABLE
1797: # USED BY THE DATATYPE FUNCTION (SCNMT IN THE CONSTANT SEC)
1798: #
1799: # BLOCK CODES FOR ACCESSIBLE DATATYPES
1800: #
1801: .set bl$ar,0 # arblk array
1802: .set bl$bc,bl$ar+1 # bcblk buffer
1803: .set bl$cd,bl$bc+1 # cdblk code
1804: .set bl$ex,bl$cd+1 # exblk expression
1805: .set bl$ic,bl$ex+1 # icblk integer
1806: .set bl$nm,bl$ic+1 # nmblk name
1807: .set bl$p0,bl$nm+1 # p0blk pattern
1808: .set bl$p1,bl$p0+1 # p1blk pattern
1809: .set bl$p2,bl$p1+1 # p2blk pattern
1810: .set bl$rc,bl$p2+1 # rcblk real
1811: .set bl$sc,bl$rc+1 # scblk string
1812: .set bl$se,bl$sc+1 # seblk expression
1813: .set bl$tb,bl$se+1 # tbblk table
1814: .set bl$vc,bl$tb+1 # vcblk array
1815: .set bl$xn,bl$vc+1 # xnblk external
1816: .set bl$xr,bl$xn+1 # xrblk external
1817: .set bl$pd,bl$xr+1 # pdblk program defined datatype
1818: #
1819: .set bl$$d,bl$pd+1 # number of block codes for data
1820: #
1821: # OTHER BLOCK CODES
1822: #
1823: .set bl$tr,bl$pd+1 # trblk
1824: .set bl$bf,bl$tr+1 # bfblk
1825: .set bl$cc,bl$bf+1 # ccblk
1826: .set bl$cm,bl$cc+1 # cmblk
1827: .set bl$ct,bl$cm+1 # ctblk
1828: .set bl$df,bl$ct+1 # dfblk
1829: .set bl$ef,bl$df+1 # efblk
1830: .set bl$ev,bl$ef+1 # evblk
1831: .set bl$ff,bl$ev+1 # ffblk
1832: .set bl$kv,bl$ff+1 # kvblk
1833: .set bl$pf,bl$kv+1 # pfblk
1834: .set bl$te,bl$pf+1 # teblk
1835: #
1836: .set bl$$i,0 # default identification code
1837: .set bl$$t,bl$tr+1 # code for data or trace block
1838: .set bl$$$,bl$te+1 # number of block codes
1839: #page
1840: #
1841: # FIELD REFERENCES
1842: #
1843: # REFERENCES TO THE FIELDS OF DATA BLOCKS ARE SYMBOLIC
1844: # (I.E. USE THE SYMBOLIC OFFSETS) WITH THE FOLLOWING
1845: # EXCEPTIONS.
1846: #
1847: # 1) REFERENCES TO THE FIRST WORD ARE USUALLY NOT
1848: # SYMBOLIC SINCE THEY USE THE (X) OPERAND FORMAT.
1849: #
1850: # 2) THE CODE WHICH CONSTRUCTS A BLOCK IS OFTEN NOT
1851: # SYMBOLIC AND SHOULD BE CHANGED IF THE CORRESPONDING
1852: # BLOCK FORMAT IS MODIFIED.
1853: #
1854: # 3) THE PLC AND PSC INSTRUCTIONS IMPLY AN OFFSET
1855: # CORRESPONDING TO THE DEFINITION OF CFP$F.
1856: #
1857: # 4) THERE ARE NON-SYMBOLIC REFERENCES (EASILY CHANGED)
1858: # IN THE GARBAGE COLLECTOR (PROCEDURES GBCPF, BLKLN).
1859: #
1860: # 5) THE FIELDS IDVAL, FARGS APPEAR IN SEVERAL BLOCKS
1861: # AND ANY CHANGES MUST BE MADE IN PARALLEL TO ALL
1862: # BLOCKS CONTAINING THE FIELDS. THE ACTUAL REFERENCES
1863: # TO THESE FIELDS ARE SYMBOLIC WITH THE ABOVE
1864: # LISTED EXCEPTIONS.
1865: #
1866: # 6) SEVERAL SPOTS IN THE CODE ASSUME THAT THE
1867: # DEFINITIONS OF THE FIELDS VRVAL, TEVAL, TRNXT ARE
1868: # THE SAME (THESE ARE SECTIONS OF CODE WHICH SEARCH
1869: # OUT ALONG A TRBLK CHAIN FROM A VARIABLE).
1870: #
1871: # 7) REFERENCES TO THE FIELDS OF AN ARRAY BLOCK IN THE
1872: # ARRAY REFERENCE ROUTINE ARREF ARE NON-SYMBOLIC.
1873: #
1874: # APART FROM THE EXCEPTIONS LISTED, REFERENCES ARE SYMBOLIC
1875: # AS FAR AS POSSIBLE AND MODIFYING THE ORDER OR NUMBER
1876: # OF FIELDS WILL NOT REQUIRE CHANGES.
1877: #page
1878: #
1879: # COMMON FIELDS FOR FUNCTION BLOCKS
1880: #
1881: # BLOCKS WHICH REPRESENT CALLABLE FUNCTIONS HAVE TWO
1882: # COMMON FIELDS AT THE START OF THE BLOCK AS FOLLOWS.
1883: #
1884: # +------------------------------------+
1885: # I FCODE I
1886: # +------------------------------------+
1887: # I FARGS I
1888: # +------------------------------------+
1889: # / /
1890: # / REST OF FUNCTION BLOCK /
1891: # / /
1892: # +------------------------------------+
1893: #
1894: .set fcode,0 # pointer to code for function
1895: .set fargs,1 # number of arguments
1896: #
1897: # FCODE IS A POINTER TO THE LOCATION IN THE INTERPRETOR
1898: # PROGRAM WHICH PROCESSES THIS TYPE OF FUNCTION CALL.
1899: #
1900: # FARGS IS THE EXPECTED NUMBER OF ARGUMENTS. THE ACTUAL
1901: # NUMBER OF ARGUMENTS IS ADJUSTED TO THIS AMOUNT BY
1902: # DELETING EXTRA ARGUMENTS OR SUPPLYING TRAILING NULLS
1903: # FOR MISSING ONES BEFORE TRANSFERRING THOUGH FCODE.
1904: # A VALUE OF 999 MAY BE USED IN THIS FIELD TO INDICATE A
1905: # VARIABLE NUMBER OF ARGUMENTS (SEE SVBLK FIELD SVNAR).
1906: #
1907: # THE BLOCK TYPES WHICH FOLLOW THIS SCHEME ARE.
1908: #
1909: # FFBLK FIELD FUNCTION
1910: # DFBLK DATATYPE FUNCTION
1911: # PFBLK PROGRAM DEFINED FUNCTION
1912: # EFBLK EXTERNAL LOADED FUNCTION
1913: #page
1914: #
1915: # IDENTIFICATION FIELD
1916: #
1917: #
1918: # ID FIELD
1919: #
1920: # CERTAIN PROGRAM ACCESSIBLE OBJECTS (THOSE WHICH CONTAIN
1921: # OTHER DATA VALUES AND CAN BE COPIED) ARE GIVEN A UNIQUE
1922: # IDENTIFICATION NUMBER (SEE EXSID). THIS ID VALUE IS AN
1923: # ADDRESS INTEGER VALUE WHICH IS ALWAYS STORED IN WORD TWO.
1924: #
1925: .set idval,1 # id value field
1926: #
1927: # THE BLOCKS CONTAINING AN IDVAL FIELD ARE.
1928: #
1929: # ARBLK ARRAY
1930: # BCBLK BUFFER CONTROL BLOCK
1931: # PDBLK PROGRAM DEFINED DATATYPE
1932: # TBBLK TABLE
1933: # VCBLK VECTOR BLOCK (ARRAY)
1934: #
1935: # NOTE THAT A ZERO IDVAL MEANS THAT THE BLOCK IS ONLY
1936: # HALF BUILT AND SHOULD NOT BE DUMPED (SEE DUMPR).
1937: #page
1938: #
1939: # ARRAY BLOCK (ARBLK)
1940: #
1941: # AN ARRAY BLOCK REPRESENTS AN ARRAY VALUE OTHER THAN ONE
1942: # WITH ONE DIMENSION WHOSE LOWER BOUND IS ONE (SEE VCBLK).
1943: # AN ARBLK IS BUILT WITH A CALL TO THE FUNCTIONS CONVERT
1944: # (S$CNV) OR ARRAY (S$ARR).
1945: #
1946: # +------------------------------------+
1947: # I ARTYP I
1948: # +------------------------------------+
1949: # I IDVAL I
1950: # +------------------------------------+
1951: # I ARLEN I
1952: # +------------------------------------+
1953: # I AROFS I
1954: # +------------------------------------+
1955: # I ARNDM I
1956: # +------------------------------------+
1957: # * ARLBD *
1958: # +------------------------------------+
1959: # * ARDIM *
1960: # +------------------------------------+
1961: # * *
1962: # * ABOVE 2 FLDS REPEATED FOR EACH DIM *
1963: # * *
1964: # +------------------------------------+
1965: # I ARPRO I
1966: # +------------------------------------+
1967: # / /
1968: # / ARVLS /
1969: # / /
1970: # +------------------------------------+
1971: #page
1972: #
1973: # ARRAY BLOCK (CONTINUED)
1974: #
1975: .set artyp,0 # pointer to dummy routine b$art
1976: .set arlen,idval+1 # length of arblk in bytes
1977: .set arofs,arlen+1 # offset in arblk to arpro field
1978: .set arndm,arofs+1 # number of dimensions
1979: .set arlbd,arndm+1 # low bound (first subscript)
1980: .set ardim,arlbd+cfp$i# dimension (first subscript)
1981: .set arlb2,ardim+cfp$i# low bound (second subscript)
1982: .set ardm2,arlb2+cfp$i# dimension (second subscript)
1983: .set arpro,ardim+cfp$i# array prototype (one dimension)
1984: .set arvls,arpro+1 # start of values (one dimension)
1985: .set arpr2,ardm2+cfp$i# array prototype (two dimensions)
1986: .set arvl2,arpr2+1 # start of values (two dimensions)
1987: .set arsi$,arlbd # number of standard fields in block
1988: .set ardms,arlb2-arlbd# size of info for one set of bounds
1989: #
1990: # THE BOUNDS AND DIMENSION FIELDS ARE SIGNED INTEGER
1991: # VALUES AND EACH OCCUPY CFP$I WORDS IN THE ARBLK.
1992: #
1993: # THE LENGTH OF AN ARBLK IN BYTES MAY NOT EXCEED MXLEN.
1994: # THIS IS REQUIRED TO KEEP NAME OFFSETS GARBAGE COLLECTABLE
1995: #
1996: # THE ACTUAL VALUES ARE ARRANGED IN ROW-WISE ORDER AND
1997: # CAN CONTAIN A DATA POINTER OR A POINTER TO A TRBLK.
1998: #
1999: # BUFFER CONTROL BLOCK (BCBLK)
2000: #
2001: # A BCBLK IS BUILT FOR EVERY BFBLK.
2002: #
2003: # +------------------------------------+
2004: # I BCTYP I
2005: # +------------------------------------+
2006: # I IDVAL I
2007: # +------------------------------------+
2008: # I BCLEN I
2009: # +------------------------------------+
2010: # I BCBUF I
2011: # +------------------------------------+
2012: #
2013: .set bctyp,0 # ptr to dummy routine b$bct
2014: .set bclen,idval+1 # defined buffer length
2015: .set bcbuf,bclen+1 # ptr to bfblk
2016: .set bcsi$,bcbuf+1 # size of bcblk
2017: #
2018: # A BCBLK IS AN INDIRECT CONTROL HEADER FOR BFBLK.
2019: # THE REASON FOR NOT STORING THIS DATA DIRECTLY
2020: # IN THE RELATED BFBLK IS SO THAT THE BFBLK CAN
2021: # MAINTAIN THE SAME SKELETAL STRUCTURE AS AN SCBLK
2022: # THUS FACILITATING TRANSPARENT STRING OPERATIONS
2023: # (FOR THE MOST PART). SPECIFICALLY, CFP$F IS THE
2024: # SAME FOR A BFBLK AS FOR AN SCBLK. BY CONVENTION,
2025: # WHEREEVER A BUFFER VALUE IS EMPLOYED, THE BCBLK
2026: # IS POINTED TO.
2027: #
2028: # THE CORRESPONDING BFBLK IS POINTED TO BY THE
2029: # BCBUF POINTER IN THE BCBLK.
2030: #
2031: # BCLEN IS THE CURRENT DEFINED SIZE OF THE CHARACTER
2032: # ARRAY IN THE BFBLK. CHARACTERS FOLLOWING THE OFFSET
2033: # OF BCLEN ARE UNDEFINED.
2034: #
2035: #page
2036: #
2037: # STRING BUFFER BLOCK (BFBLK)
2038: #
2039: # A BFBLK IS BUILT BY A CALL TO BUFFER(...)
2040: #
2041: # +------------------------------------+
2042: # I BFTYP I
2043: # +------------------------------------+
2044: # I BFALC I
2045: # +------------------------------------+
2046: # / /
2047: # / BFCHR /
2048: # / /
2049: # +------------------------------------+
2050: #
2051: .set bftyp,0 # ptr to dummy routine b$bft
2052: .set bfalc,bftyp+1 # allocated size of buffer
2053: .set bfchr,bfalc+1 # characters of string
2054: .set bfsi$,bfchr # size of standard fields in bfblk
2055: #
2056: # THE CHARACTERS IN THE BUFFER ARE STORED LEFT JUSTIFIED.
2057: # THE FINAL WORD OF DEFINED CHARACTERS IS ALWAYS ZERO
2058: # (CHARACTER) PADDED. ANY TRAILING ALLOCATION PAST THE
2059: # WORD CONTAINING THE LAST CHARACTER CONTAINS
2060: # UNPREDICTABLE CONTENTS AND IS NEVER REFERENCED.
2061: #
2062: # NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING
2063: # IS GIVEN BY CFP$F, AS WITH AN SCBLK. HOWEVER, THE
2064: # OFFSET WHICH IS OCCUPIED BY THE LENGTH FOR AN SCBLK
2065: # IS THE TOTAL CHAR SPACE FOR BFBLKS, AND ROUTINES WHICH
2066: # DEAL WITH BOTH MUST ACCOUNT FOR THIS DIFFERENCE.
2067: #
2068: # THE VALUE OF BFALC MAY NOT EXCEED MXLEN. THE VALUE OF
2069: # BCLEN IS ALWAYS LESS THAN OR EQUAL TO BFALC.
2070: #
2071: #page
2072: #
2073: # CODE CONSTRUCTION BLOCK (CCBLK)
2074: #
2075: # AT ANY ONE MOMENT THERE IS AT MOST ONE CCBLK INTO
2076: # WHICH THE COMPILER IS CURRENTLY STORING CODE (CDWRD).
2077: #
2078: # +------------------------------------+
2079: # I CCTYP I
2080: # +------------------------------------+
2081: # I CCLEN I
2082: # +------------------------------------+
2083: # I CCUSE I
2084: # +------------------------------------+
2085: # / /
2086: # / CCCOD /
2087: # / /
2088: # +------------------------------------+
2089: #
2090: .set cctyp,0 # pointer to dummy routine b$cct
2091: .set cclen,cctyp+1 # length of ccblk in bytes
2092: .set ccuse,cclen+1 # offset past last used word (bytes)
2093: .set cccod,ccuse+1 # start of generated code in block
2094: #
2095: # THE REASON THAT THE CCBLK IS A SEPARATE BLOCK TYPE FROM
2096: # THE USUAL CDBLK IS THAT THE GARBAGE COLLECTOR MUST
2097: # ONLY PROCESS THOSE FIELDS WHICH HAVE BEEN SET (SEE GBCPF)
2098: #page
2099: #
2100: # CODE BLOCK (CDBLK)
2101: #
2102: # A CODE BLOCK IS BUILT FOR EACH STATEMENT COMPILED DURING
2103: # THE INITIAL COMPILATION OR BY SUBSEQUENT CALLS TO CODE.
2104: #
2105: # +------------------------------------+
2106: # I CDJMP I
2107: # +------------------------------------+
2108: # I CDSTM I
2109: # +------------------------------------+
2110: # I CDLEN I
2111: # +------------------------------------+
2112: # I CDFAL I
2113: # +------------------------------------+
2114: # / /
2115: # / CDCOD /
2116: # / /
2117: # +------------------------------------+
2118: #
2119: .set cdjmp,0 # ptr to routine to execute statement
2120: .set cdstm,cdjmp+1 # statement number
2121: .set cdlen,offs2 # length of cdblk in bytes
2122: .set cdfal,offs3 # failure exit (see below)
2123: .set cdcod,cdfal+1 # executable pseudo-code
2124: .set cdsi$,cdcod # number of standard fields in cdblk
2125: #
2126: # CDSTM IS THE STATEMENT NUMBER OF THE CURRENT STATEMENT.
2127: #
2128: # CDJMP, CDFAL ARE SET AS FOLLOWS.
2129: #
2130: # 1) IF THE FAILURE EXIT IS THE NEXT STATEMENT
2131: #
2132: # CDJMP = B$CDS
2133: # CDFAL = PTR TO CDBLK FOR NEXT STATEMENT
2134: #
2135: # 2) IF THE FAILURE EXIT IS A SIMPLE LABEL NAME
2136: #
2137: # CDJMP = B$CDS
2138: # CDFAL IS A PTR TO THE VRTRA FIELD OF THE VRBLK
2139: #
2140: # 3) IF THERE IS NO FAILURE EXIT (-NOFAIL MODE)
2141: #
2142: # CDJMP = B$CDS
2143: # CDFAL = O$UNF
2144: #
2145: # 4) IF THE FAILURE EXIT IS COMPLEX OR DIRECT
2146: #
2147: # CDJMP = B$CDC
2148: # CDFAL IS THE OFFSET TO THE O$GOF WORD
2149: #page
2150: #
2151: # CODE BLOCK (CONTINUED)
2152: #
2153: # CDCOD IS THE START OF THE ACTUAL CODE. FIRST WE DESCRIBE
2154: # THE CODE GENERATED FOR AN EXPRESSION. IN AN EXPRESSION,
2155: # ELEMENTS ARE FETCHED BY NAME OR BY VALUE. FOR EXAMPLE,
2156: # THE BINARY EQUAL OPERATOR FETCHES ITS LEFT ARGUMENT
2157: # BY NAME AND ITS RIGHT ARGUMENT BY VALUE. THESE TWO
2158: # CASES GENERATE QUITE DIFFERENT CODE AND ARE DESCRIBED
2159: # SEPARATELY. FIRST WE CONSIDER THE CODE BY VALUE CASE.
2160: #
2161: # GENERATION OF CODE BY VALUE FOR EXPRESSIONS ELEMENTS.
2162: #
2163: # EXPRESSION POINTER TO EXBLK OR SEBLK
2164: #
2165: # INTEGER CONSTANT POINTER TO ICBLK
2166: #
2167: # NULL CONSTANT POINTER TO NULLS
2168: #
2169: # PATTERN (RESULTING FROM PREEVALUATION)
2170: # =O$LPT
2171: # POINTER TO P0BLK,P1BLK OR P2BLK
2172: #
2173: # REAL CONSTANT POINTER TO RCBLK
2174: #
2175: # STRING CONSTANT POINTER TO SCBLK
2176: #
2177: # VARIABLE POINTER TO VRGET FIELD OF VRBLK
2178: #
2179: # ADDITION VALUE CODE FOR LEFT OPERAND
2180: # VALUE CODE FOR RIGHT OPERAND
2181: # =O$ADD
2182: #
2183: # AFFIRMATION VALUE CODE FOR OPERAND
2184: # =O$AFF
2185: #
2186: # ALTERNATION VALUE CODE FOR LEFT OPERAND
2187: # VALUE CODE FOR RIGHT OPERAND
2188: # =O$ALT
2189: #
2190: # ARRAY REFERENCE (CASE OF ONE SUBSCRIPT)
2191: # VALUE CODE FOR ARRAY OPERAND
2192: # VALUE CODE FOR SUBSCRIPT OPERAND
2193: # =O$AOV
2194: #
2195: # (CASE OF MORE THAN ONE SUBSCRIPT)
2196: # VALUE CODE FOR ARRAY OPERAND
2197: # VALUE CODE FOR FIRST SUBSCRIPT
2198: # VALUE CODE FOR SECOND SUBSCRIPT
2199: # ...
2200: # VALUE CODE FOR LAST SUBSCRIPT
2201: # =O$AMV
2202: # NUMBER OF SUBSCRIPTS
2203: #page
2204: #
2205: # CODE BLOCK (CONTINUED)
2206: #
2207: # ASSIGNMENT (TO NATURAL VARIABLE)
2208: # VALUE CODE FOR RIGHT OPERAND
2209: # POINTER TO VRSTO FIELD OF VRBLK
2210: #
2211: # (TO ANY OTHER VARIABLE)
2212: # NAME CODE FOR LEFT OPERAND
2213: # VALUE CODE FOR RIGHT OPERAND
2214: # =O$ASS
2215: #
2216: # COMPILE ERROR =O$CER
2217: #
2218: #
2219: # COMPLEMENTATION VALUE CODE FOR OPERAND
2220: # =O$COM
2221: #
2222: # CONCATENATION (CASE OF PRED FUNC LEFT OPERAND)
2223: # VALUE CODE FOR LEFT OPERAND
2224: # =O$POP
2225: # VALUE CODE FOR RIGHT OPERAND
2226: #
2227: # (ALL OTHER CASES)
2228: # VALUE CODE FOR LEFT OPERAND
2229: # VALUE CODE FOR RIGHT OPERAND
2230: # =O$CNC
2231: #
2232: # CURSOR ASSIGNMENT NAME CODE FOR OPERAND
2233: # =O$CAS
2234: #
2235: # DIVISION VALUE CODE FOR LEFT OPERAND
2236: # VALUE CODE FOR RIGHT OPERAND
2237: # =O$DVD
2238: #
2239: # EXPONENTIATION VALUE CODE FOR LEFT OPERAND
2240: # VALUE CODE FOR RIGHT OPERAND
2241: # =O$EXP
2242: #
2243: # FUNCTION CALL (CASE OF CALL TO SYSTEM FUNCTION)
2244: # VALUE CODE FOR FIRST ARGUMENT
2245: # VALUE CODE FOR SECOND ARGUMENT
2246: # ...
2247: # VALUE CODE FOR LAST ARGUMENT
2248: # POINTER TO SVFNC FIELD OF SVBLK
2249: #
2250: #page
2251: #
2252: # CODE BLOCK (CONTINUED)
2253: #
2254: # FUNCTION CALL (CASE OF NON-SYSTEM FUNCTION 1 ARG)
2255: # VALUE CODE FOR ARGUMENT
2256: # =O$FNS
2257: # POINTER TO VRBLK FOR FUNCTION
2258: #
2259: # (NON-SYSTEM FUNCTION, GT 1 ARG)
2260: # VALUE CODE FOR FIRST ARGUMENT
2261: # VALUE CODE FOR SECOND ARGUMENT
2262: # ...
2263: # VALUE CODE FOR LAST ARGUMENT
2264: # =O$FNC
2265: # NUMBER OF ARGUMENTS
2266: # POINTER TO VRBLK FOR FUNCTION
2267: #
2268: # IMMEDIATE ASSIGNMENT VALUE CODE FOR LEFT OPERAND
2269: # NAME CODE FOR RIGHT OPERAND
2270: # =O$IMA
2271: #
2272: # INDIRECTION VALUE CODE FOR OPERAND
2273: # =O$INV
2274: #
2275: # INTERROGATION VALUE CODE FOR OPERAND
2276: # =O$INT
2277: #
2278: # KEYWORD REFERENCE NAME CODE FOR OPERAND
2279: # =O$KWV
2280: #
2281: # MULTIPLICATION VALUE CODE FOR LEFT OPERAND
2282: # VALUE CODE FOR RIGHT OPERAND
2283: # =O$MLT
2284: #
2285: # NAME REFERENCE (NATURAL VARIABLE CASE)
2286: # POINTER TO NMBLK FOR NAME
2287: #
2288: # (ALL OTHER CASES)
2289: # NAME CODE FOR OPERAND
2290: # =O$NAM
2291: #
2292: # NEGATION =O$NTA
2293: # CDBLK OFFSET OF O$NTC WORD
2294: # VALUE CODE FOR OPERAND
2295: # =O$NTB
2296: # =O$NTC
2297: #page
2298: #
2299: # CODE BLOCK (CONTINUED)
2300: #
2301: # PATTERN ASSIGNMENT VALUE CODE FOR LEFT OPERAND
2302: # NAME CODE FOR RIGHT OPERAND
2303: # =O$PAS
2304: #
2305: # PATTERN MATCH VALUE CODE FOR LEFT OPERAND
2306: # VALUE CODE FOR RIGHT OPERAND
2307: # =O$PMV
2308: #
2309: # PATTERN REPLACEMENT NAME CODE FOR SUBJECT
2310: # VALUE CODE FOR PATTERN
2311: # =O$PMN
2312: # VALUE CODE FOR REPLACEMENT
2313: # =O$RPL
2314: #
2315: # SELECTION (FOR FIRST ALTERNATIVE)
2316: # =O$SLA
2317: # CDBLK OFFSET TO NEXT O$SLC WORD
2318: # VALUE CODE FOR FIRST ALTERNATIVE
2319: # =O$SLB
2320: # CDBLK OFFSET PAST ALTERNATIVES
2321: #
2322: # (FOR SUBSEQUENT ALTERNATIVES)
2323: # =O$SLC
2324: # CDBLK OFFSET TO NEXT O$SLC,O$SLD
2325: # VALUE CODE FOR ALTERNATIVE
2326: # =O$SLB
2327: # OFFSET IN CDBLK PAST ALTERNATIVES
2328: #
2329: # (FOR LAST ALTERNATIVE)
2330: # =O$SLD
2331: # VALUE CODE FOR LAST ALTERNATIVE
2332: #
2333: # SUBTRACTION VALUE CODE FOR LEFT OPERAND
2334: # VALUE CODE FOR RIGHT OPERAND
2335: # =O$SUB
2336: #page
2337: #
2338: # CODE BLOCK (CONTINUED)
2339: #
2340: # GENERATION OF CODE BY NAME FOR EXPRESSION ELEMENTS.
2341: #
2342: # VARIABLE =O$LVN
2343: # POINTER TO VRBLK
2344: #
2345: # EXPRESSION (CASE OF *NATURAL VARIABLE)
2346: # =O$LVN
2347: # POINTER TO VRBLK
2348: #
2349: # (ALL OTHER CASES)
2350: # =O$LEX
2351: # POINTER TO EXBLK
2352: #
2353: #
2354: # ARRAY REFERENCE (CASE OF ONE SUBSCRIPT)
2355: # VALUE CODE FOR ARRAY OPERAND
2356: # VALUE CODE FOR SUBSCRIPT OPERAND
2357: # =O$AON
2358: #
2359: # (CASE OF MORE THAN ONE SUBSCRIPT)
2360: # VALUE CODE FOR ARRAY OPERAND
2361: # VALUE CODE FOR FIRST SUBSCRIPT
2362: # VALUE CODE FOR SECOND SUBSCRIPT
2363: # ...
2364: # VALUE CODE FOR LAST SUBSCRIPT
2365: # =O$AMN
2366: # NUMBER OF SUBSCRIPTS
2367: #
2368: # COMPILE ERROR =O$CER
2369: #
2370: # FUNCTION CALL (SAME CODE AS FOR VALUE CALL)
2371: # =O$FNE
2372: #
2373: # INDIRECTION VALUE CODE FOR OPERAND
2374: # =O$INN
2375: #
2376: # KEYWORD REFERENCE NAME CODE FOR OPERAND
2377: # =O$KWN
2378: #
2379: # ANY OTHER OPERAND IS AN ERROR IN A NAME POSITION
2380: #
2381: # NOTE THAT IN THIS DESCRIPTION, =O$XXX REFERS TO THE
2382: # GENERATION OF A WORD CONTAINING THE ADDRESS OF ANOTHER
2383: # WORD WHICH CONTAINS THE ENTRY POINT ADDRESS O$XXX.
2384: #page
2385: #
2386: # CODE BLOCK (CONTINUED)
2387: #
2388: # NOW WE CONSIDER THE OVERALL STRUCTURE OF THE CODE BLOCK
2389: # FOR A STATEMENT WITH POSSIBLE GOTO FIELDS.
2390: #
2391: # FIRST COMES THE CODE FOR THE STATEMENT BODY.
2392: # THE STATEMENT BODY IS AN EXPRESSION TO BE EVALUATED
2393: # BY VALUE ALTHOUGH THE VALUE IS NOT ACTUALLY REQUIRED.
2394: # NORMAL VALUE CODE IS GENERATED FOR THE BODY OF THE
2395: # STATEMENT EXCEPT IN THE CASE OF A PATTERN MATCH BY
2396: # VALUE, IN WHICH CASE THE FOLLOWING IS GENERATED.
2397: #
2398: # VALUE CODE FOR LEFT OPERAND
2399: # VALUE CODE FOR RIGHT OPERAND
2400: # =O$PMS
2401: #
2402: # NEXT WE HAVE THE CODE FOR THE SUCCESS GOTO. THERE ARE
2403: # SEVERAL CASES AS FOLLOWS.
2404: #
2405: # 1) NO SUCCESS GOTO PTR TO CDBLK FOR NEXT STATEMENT
2406: #
2407: # 2) SIMPLE LABEL PTR TO VRTRA FIELD OF VRBLK
2408: #
2409: # 3) COMPLEX GOTO (CODE BY NAME FOR GOTO OPERAND)
2410: # =O$GOC
2411: #
2412: # 4) DIRECT GOTO (CODE BY VALUE FOR GOTO OPERAND)
2413: # =O$GOD
2414: #
2415: # FOLLOWING THIS WE GENERATE CODE FOR THE FAILURE GOTO IF
2416: # IT IS DIRECT OR IF IT IS COMPLEX, SIMPLE FAILURE GOTOS
2417: # HAVING BEEN HANDLED BY AN APPROPRIATE SETTING OF THE
2418: # CDFAL FIELD OF THE CDBLK. THE GENERATED CODE IS ONE
2419: # OF THE FOLLOWING.
2420: #
2421: # 1) COMPLEX FGOTO =O$FIF
2422: # =O$GOF
2423: # NAME CODE FOR GOTO OPERAND
2424: # =O$GOC
2425: #
2426: # 2) DIRECT FGOTO =O$FIF
2427: # =O$GOF
2428: # VALUE CODE FOR GOTO OPERAND
2429: # =O$GOD
2430: #
2431: # AN OPTIMIZATION OCCURS IF THE SUCCESS AND FAILURE GOTOS
2432: # ARE IDENTICAL AND EITHER COMPLEX OR DIRECT. IN THIS CASE,
2433: # NO CODE IS GENERATED FOR THE SUCCESS GOTO AND CONTROL
2434: # IS ALLOWED TO FALL INTO THE FAILURE GOTO ON SUCCESS.
2435: #page
2436: #
2437: # COMPILER BLOCK (CMBLK)
2438: #
2439: # A COMPILER BLOCK (CMBLK) IS BUILT BY EXPAN TO REPRESENT
2440: # ONE NODE OF A TREE STRUCTURED EXPRESSION REPRESENTATION.
2441: #
2442: # +------------------------------------+
2443: # I CMIDN I
2444: # +------------------------------------+
2445: # I CMLEN I
2446: # +------------------------------------+
2447: # I CMTYP I
2448: # +------------------------------------+
2449: # I CMOPN I
2450: # +------------------------------------+
2451: # / CMVLS OR CMROP /
2452: # / /
2453: # / CMLOP /
2454: # / /
2455: # +------------------------------------+
2456: #
2457: .set cmidn,0 # pointer to dummy routine b$cmt
2458: .set cmlen,cmidn+1 # length of cmblk in bytes
2459: .set cmtyp,cmlen+1 # type (c$xxx, see list below)
2460: .set cmopn,cmtyp+1 # operand pointer (see below)
2461: .set cmvls,cmopn+1 # operand value pointers (see below)
2462: .set cmrop,cmvls # right (only) operator operand
2463: .set cmlop,cmvls+1 # left operator operand
2464: .set cmsi$,cmvls # number of standard fields in cmblk
2465: .set cmus$,cmsi$+1 # size of unary operator cmblk
2466: .set cmbs$,cmsi$+2 # size of binary operator cmblk
2467: .set cmar1,cmvls+1 # array subscript pointers
2468: #
2469: # THE CMOPN AND CMVLS FIELDS ARE SET AS FOLLOWS
2470: #
2471: # ARRAY REFERENCE CMOPN = PTR TO ARRAY OPERAND
2472: # CMVLS = PTRS TO SUBSCRIPT OPERANDS
2473: #
2474: # FUNCTION CALL CMOPN = PTR TO VRBLK FOR FUNCTION
2475: # CMVLS = PTRS TO ARGUMENT OPERANDS
2476: #
2477: # SELECTION CMOPN = ZERO
2478: # CMVLS = PTRS TO ALTERNATE OPERANDS
2479: #
2480: # UNARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK
2481: # CMROP = PTR TO OPERAND
2482: #
2483: # BINARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK
2484: # CMROP = PTR TO RIGHT OPERAND
2485: # CMLOP = PTR TO LEFT OPERAND
2486: #page
2487: #
2488: # CMTYP IS SET TO INDICATE THE TYPE OF EXPRESSION ELEMENT
2489: # AS SHOWN BY THE FOLLOWING TABLE OF DEFINITIONS.
2490: #
2491: .set c$arr,0 # array reference
2492: .set c$fnc,c$arr+1 # function call
2493: .set c$def,c$fnc+1 # deferred expression (unary *)
2494: .set c$ind,c$def+1 # indirection (unary $)
2495: .set c$key,c$ind+1 # keyword reference (unary ampersand)
2496: .set c$ubo,c$key+1 # undefined binary operator
2497: .set c$uuo,c$ubo+1 # undefined unary operator
2498: .set c$uo$,c$uuo+1 # test value (=c$uuo+1=c$ubo+2)
2499: .set c$$nm,c$uuo+1 # number of codes for name operands
2500: #
2501: # THE REMAINING TYPES INDICATE EXPRESSION ELEMENTS WHICH
2502: # CAN ONLY BE EVALUATED BY VALUE (NOT BY NAME).
2503: #
2504: .set c$bvl,c$uuo+1 # binary op with value operands
2505: .set c$uvl,c$bvl+1 # unary operator with value operand
2506: .set c$alt,c$uvl+1 # alternation (binary bar)
2507: .set c$cnc,c$alt+1 # concatenation
2508: .set c$cnp,c$cnc+1 # concatenation, not pattern match
2509: .set c$unm,c$cnp+1 # unary op with name operand
2510: .set c$bvn,c$unm+1 # binary op (operands by value, name)
2511: .set c$ass,c$bvn+1 # assignment
2512: .set c$int,c$ass+1 # interrogation
2513: .set c$neg,c$int+1 # negation (unary not)
2514: .set c$sel,c$neg+1 # selection
2515: .set c$pmt,c$sel+1 # pattern match
2516: #
2517: .set c$pr$,c$bvn # last preevaluable code
2518: .set c$$nv,c$pmt+1 # number of different cmblk types
2519: #page
2520: #
2521: # CHARACTER TABLE BLOCK (CTBLK)
2522: #
2523: # A CHARACTER TABLE BLOCK IS USED TO HOLD LOGICAL CHARACTER
2524: # TABLES FOR USE WITH ANY,NOTANY,SPAN,BREAK,BREAKX
2525: # PATTERNS. EACH CHARACTER TABLE CAN BE USED TO STORE
2526: # CFP$N DISTINCT TABLES AS BIT COLUMNS. A BIT COLUMN
2527: # ALLOCATED FOR EACH ARGUMENT OF MORE THAN ONE CHARACTER
2528: # IN LENGTH TO ONE OF THE ABOVE LISTED PATTERN PRIMITIVES.
2529: #
2530: # +------------------------------------+
2531: # I CTTYP I
2532: # +------------------------------------+
2533: # * *
2534: # * *
2535: # * CTCHS *
2536: # * *
2537: # * *
2538: # +------------------------------------+
2539: #
2540: .set cttyp,0 # pointer to dummy routine b$ctt
2541: .set ctchs,cttyp+1 # start of character table words
2542: .set ctsi$,ctchs+cfp$a# number of words in ctblk
2543: #
2544: # CTCHS IS CFP$A WORDS LONG AND CONSISTS OF A ONE WORD
2545: # BIT STRING VALUE FOR EACH POSSIBLE CHARACTER IN THE
2546: # INTERNAL ALPHABET. EACH OF THE CFP$N POSSIBLE BITS IN
2547: # A BITSTRING IS USED TO FORM A COLUMN OF BIT INDICATORS.
2548: # A BIT IS SET ON IF THE CHARACTER IS IN THE TABLE AND OFF
2549: # IF THE CHARACTER IS NOT PRESENT.
2550: #page
2551: #
2552: # DATATYPE FUNCTION BLOCK (DFBLK)
2553: #
2554: # A DATATYPE FUNCTION IS USED TO CONTROL THE CONSTRUCTION
2555: # OF A PROGRAM DEFINED DATATYPE OBJECT. A CALL TO THE
2556: # SYSTEM FUNCTION DATA BUILDS A DFBLK FOR THE DATATYPE NAME
2557: #
2558: # NOTE THAT THESE BLOCKS ARE BUILT IN STATIC BECAUSE PDBLK
2559: # LENGTH IS GOT FROM DFLEN FIELD. IF DFBLK WAS IN DYNAMIC
2560: # STORE THIS WOULD CAUSE TROUBLE DURING PASS TWO OF GARBAGE
2561: # COLLECTION. SCBLK REFERRED TO BY DFNAM FIELD IS ALSO PUT
2562: # IN STATIC SO THAT THERE ARE NO RELOC. FIELDS. THIS CUTS
2563: # GARBAGE COLLECTION TASK APPRECIABLY FOR PDBLKS WHICH ARE
2564: # LIKELY TO BE PRESENT IN LARGE NUMBERS.
2565: #
2566: # +------------------------------------+
2567: # I FCODE I
2568: # +------------------------------------+
2569: # I FARGS I
2570: # +------------------------------------+
2571: # I DFLEN I
2572: # +------------------------------------+
2573: # I DFPDL I
2574: # +------------------------------------+
2575: # I DFNAM I
2576: # +------------------------------------+
2577: # / /
2578: # / DFFLD /
2579: # / /
2580: # +------------------------------------+
2581: #
2582: .set dflen,fargs+1 # length of dfblk in bytes
2583: .set dfpdl,dflen+1 # length of corresponding pdblk
2584: .set dfnam,dfpdl+1 # pointer to scblk for datatype name
2585: .set dffld,dfnam+1 # start of vrblk ptrs for field names
2586: .set dfflb,dffld-1 # offset behind dffld for field func
2587: .set dfsi$,dffld # number of standard fields in dfblk
2588: #
2589: # THE FCODE FIELD POINTS TO THE ROUTINE B$DFC
2590: #
2591: # FARGS (THE NUMBER OF ARGUMENTS) IS THE NUMBER OF FIELDS.
2592: #page
2593: #
2594: # DOPE VECTOR BLOCK (DVBLK)
2595: #
2596: # A DOPE VECTOR IS ASSEMBLED FOR EACH POSSIBLE OPERATOR IN
2597: # THE SNOBOL4 LANGUAGE AS PART OF THE CONSTANT SECTION.
2598: #
2599: # +------------------------------------+
2600: # I DVOPN I
2601: # +------------------------------------+
2602: # I DVTYP I
2603: # +------------------------------------+
2604: # I DVLPR I
2605: # +------------------------------------+
2606: # I DVRPR I
2607: # +------------------------------------+
2608: #
2609: .set dvopn,0 # entry address (ptr to o$xxx)
2610: .set dvtyp,dvopn+1 # type code (c$xxx, see cmblk)
2611: .set dvlpr,dvtyp+1 # left precedence (llxxx, see below)
2612: .set dvrpr,dvlpr+1 # right precedence (rrxxx, see below)
2613: .set dvus$,dvlpr+1 # size of unary operator dv
2614: .set dvbs$,dvrpr+1 # size of binary operator dv
2615: .set dvubs,dvus$+dvbs$# size of unop + binop (see scane)
2616: #
2617: # THE CONTENTS OF THE DVTYP FIELD IS COPIED INTO THE CMTYP
2618: # FIELD OF THE CMBLK FOR THE OPERATOR IF IT IS USED.
2619: #
2620: # THE CMOPN FIELD OF AN OPERATOR CMBLK POINTS TO THE DVBLK
2621: # ITSELF, PROVIDING THE REQUIRED ENTRY ADDRESS POINTER PTR.
2622: #
2623: # FOR NORMALLY UNDEFINED OPERATORS, THE DVOPN (AND CMOPN)
2624: # FIELDS CONTAIN A WORD OFFSET FROM R$UBA OF THE FUNCTION
2625: # BLOCK POINTER FOR THE OPERATOR (INSTEAD OF O$XXX PTR).
2626: # FOR CERTAIN SPECIAL OPERATORS, THE DVOPN FIELD IS NOT
2627: # REQUIRED AT ALL AND IS ASSEMBLED AS ZERO.
2628: #
2629: # THE LEFT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO
2630: # THE LEFT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS THE
2631: # PRECEDENCE OF THE OPERATOR TOWARDS ITS RIGHT OPERAND.
2632: #
2633: # THE RIGHT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO
2634: # THE RIGHT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS
2635: # THE PRECEDENCE OF THE OPERATOR TOWARDS ITS LEFT OPERAND.
2636: #
2637: # HIGHER PRECEDENCE VALUES CORRESPOND TO A TIGHTER BINDING
2638: # CAPABILITY. THUS WE HAVE THE LEFT PRECEDENCE LOWER
2639: # (HIGHER) THAN THE RIGHT PRECEDENCE FOR RIGHT (LEFT)
2640: # ASSOCIATIVE BINARY OPERATORS.
2641: #
2642: # THE LEFT PRECEDENCE OF UNARY OPERATORS IS SET TO AN
2643: # ARBITRARY HIGH VALUE. THE RIGHT VALUE IS NOT REQUIRED AND
2644: # CONSEQUENTLY THE DVRPR FIELD IS OMITTED FOR UNARY OPS.
2645: #page
2646: #
2647: # TABLE OF OPERATOR PRECEDENCE VALUES
2648: #
2649: .set rrass,10 # right equal
2650: .set llass,00 # left equal
2651: .set rrpmt,20 # right question mark
2652: .set llpmt,30 # left question mark
2653: .set rramp,40 # right ampersand
2654: .set llamp,50 # left ampersand
2655: .set rralt,70 # right vertical bar
2656: .set llalt,60 # left vertical bar
2657: .set rrcnc,90 # right blank
2658: .set llcnc,80 # left blank
2659: .set rrats,110 # right at
2660: .set llats,100 # left at
2661: .set rrplm,120 # right plus, minus
2662: .set llplm,130 # left plus, minus
2663: .set rrnum,140 # right number
2664: .set llnum,150 # left number
2665: .set rrdvd,160 # right slash
2666: .set lldvd,170 # left slash
2667: .set rrmlt,180 # right asterisk
2668: .set llmlt,190 # left asterisk
2669: .set rrpct,200 # right percent
2670: .set llpct,210 # left percent
2671: .set rrexp,230 # right exclamation
2672: .set llexp,220 # left exclamation
2673: .set rrdld,240 # right dollar, dot
2674: .set lldld,250 # left dollar, dot
2675: .set rrnot,270 # right not
2676: .set llnot,260 # left not
2677: .set lluno,999 # left all unary operators
2678: #
2679: # PRECEDENCES ARE THE SAME AS IN BTL SNOBOL4 WITH THE
2680: # FOLLOWING EXCEPTIONS.
2681: #
2682: # 1) BINARY QUESTION MARK IS LOWERED AND MADE LEFT ASSOC-
2683: # IATIVE TO REFLECT ITS NEW USE FOR PATTERN MATCHING.
2684: #
2685: # 2) ALTERNATION AND CONCATENATION ARE MADE RIGHT
2686: # ASSOCIATIVE FOR GREATER EFFICIENCY IN PATTERN
2687: # CONSTRUCTION AND MATCHING RESPECTIVELY. THIS CHANGE
2688: # IS TRANSPARENT TO THE SNOBOL4 PROGRAMMER.
2689: #
2690: # 3) THE EQUAL SIGN HAS BEEN ADDED AS A LOW PRECEDENCE
2691: # OPERATOR WHICH IS RIGHT ASSOCIATIVE TO REFLECT ITS
2692: # MORE GENERAL USAGE IN THIS VERSION OF SNOBOL4.
2693: #page
2694: #
2695: # EXTERNAL FUNCTION BLOCK (EFBLK)
2696: #
2697: # AN EXTERNAL FUNCTION BLOCK IS USED TO CONTROL THE CALLING
2698: # OF AN EXTERNAL FUNCTION. IT IS BUILT BY A CALL TO LOAD.
2699: #
2700: # +------------------------------------+
2701: # I FCODE I
2702: # +------------------------------------+
2703: # I FARGS I
2704: # +------------------------------------+
2705: # I EFLEN I
2706: # +------------------------------------+
2707: # I EFUSE I
2708: # +------------------------------------+
2709: # I EFCOD I
2710: # +------------------------------------+
2711: # I EFVAR I
2712: # +------------------------------------+
2713: # I EFRSL I
2714: # +------------------------------------+
2715: # / /
2716: # / EFTAR /
2717: # / /
2718: # +------------------------------------+
2719: #
2720: .set eflen,fargs+1 # length of efblk in bytes
2721: .set efuse,eflen+1 # use count (for opsyn)
2722: .set efcod,efuse+1 # ptr to code (from sysld)
2723: .set efvar,efcod+1 # ptr to associated vrblk
2724: .set efrsl,efvar+1 # result type (see below)
2725: .set eftar,efrsl+1 # argument types (see below)
2726: .set efsi$,eftar # number of standard fields in efblk
2727: #
2728: # THE FCODE FIELD POINTS TO THE ROUTINE B$EFC.
2729: #
2730: # EFUSE IS USED TO KEEP TRACK OF MULTIPLE USE WHEN OPSYN
2731: # IS EMPLOYED. THE FUNCTION IS AUTOMATICALLY UNLOADED
2732: # WHEN THERE ARE NO MORE REFERENCES TO THE FUNCTION.
2733: #
2734: # EFRSL AND EFTAR ARE TYPE CODES AS FOLLOWS.
2735: #
2736: # 0 TYPE IS UNCONVERTED
2737: # 1 TYPE IS STRING
2738: # 2 TYPE IS INTEGER
2739: # 3 TYPE IS REAL
2740: #page
2741: #
2742: # EXPRESSION VARIABLE BLOCK (EVBLK)
2743: #
2744: # IN THIS VERSION OF SPITBOL, AN EXPRESSION CAN BE USED IN
2745: # ANY POSITION WHICH WOULD NORMALLY EXPECT A NAME (FOR
2746: # EXAMPLE ON THE LEFT SIDE OF EQUALS OR AS THE RIGHT
2747: # ARGUMENT OF BINARY DOT). THIS CORRESPONDS TO THE CREATION
2748: # OF A PSEUDO-VARIABLE WHICH IS REPRESENTED BY A POINTER TO
2749: # AN EXPRESSION VARIABLE BLOCK AS FOLLOWS.
2750: #
2751: # +------------------------------------+
2752: # I EVTYP I
2753: # +------------------------------------+
2754: # I EVEXP I
2755: # +------------------------------------+
2756: # I EVVAR I
2757: # +------------------------------------+
2758: #
2759: .set evtyp,0 # pointer to dummy routine b$evt
2760: .set evexp,evtyp+1 # pointer to exblk for expression
2761: .set evvar,evexp+1 # pointer to trbev dummy trblk
2762: .set evsi$,evvar+1 # size of evblk
2763: #
2764: # THE NAME OF AN EXPRESSION VARIABLE IS REPRESENTED BY A
2765: # BASE POINTER TO THE EVBLK AND AN OFFSET OF EVVAR. THIS
2766: # VALUE APPEARS TO BE TRAPPED BY THE DUMMY TRBEV BLOCK.
2767: #
2768: # NOTE THAT THERE IS NO NEED TO ALLOW FOR THE CASE OF AN
2769: # EXPRESSION VARIABLE WHICH REFERENCES AN SEBLK SINCE A
2770: # VARIABLE WHICH IS OF THE FORM *VAR IS EQUIVALENT TO VAR.
2771: #page
2772: #
2773: # EXPRESSION BLOCK (EXBLK)
2774: #
2775: # AN EXPRESSION BLOCK IS BUILT FOR EACH EXPRESSION
2776: # REFERENCED IN A PROGRAM OR CREATED BY EVAL OR CONVERT
2777: # DURING EXECUTION OF A PROGRAM.
2778: #
2779: # +------------------------------------+
2780: # I EXTYP I
2781: # +------------------------------------+
2782: # I EXSTM I
2783: # +------------------------------------+
2784: # I EXLEN I
2785: # +------------------------------------+
2786: # I EXFLC I
2787: # +------------------------------------+
2788: # / /
2789: # / EXCOD /
2790: # / /
2791: # +------------------------------------+
2792: #
2793: .set extyp,0 # ptr to routine b$exl to load expr
2794: .set exstm,cdstm # stores stmnt no. during evaluation
2795: .set exlen,exstm+1 # length of exblk in bytes
2796: .set exflc,exlen+1 # failure code (=o$fex)
2797: .set excod,exflc+1 # pseudo-code for expression
2798: .set exsi$,excod # number of standard fields in exblk
2799: #
2800: # THERE ARE TWO CASES FOR EXCOD DEPENDING ON WHETHER THE
2801: # EXPRESSION CAN BE EVALUATED BY NAME (SEE DESCRIPTION
2802: # OF CDBLK FOR DETAILS OF CODE FOR EXPRESSIONS).
2803: #
2804: # IF THE EXPRESSION CAN BE EVALUATED BY NAME WE HAVE.
2805: #
2806: # (CODE FOR EXPR BY NAME)
2807: # =O$RNM
2808: #
2809: # IF THE EXPRESSION CAN ONLY BE EVALUATED BY VALUE.
2810: #
2811: # (CODE FOR EXPR BY VALUE)
2812: # =O$RVL
2813: #page
2814: #
2815: # FIELD FUNCTION BLOCK (FFBLK)
2816: #
2817: # A FIELD FUNCTION BLOCK IS USED TO CONTROL THE SELECTION
2818: # OF A FIELD FROM A PROGRAM DEFINED DATATYPE BLOCK.
2819: # A CALL TO DATA CREATES AN FFBLK FOR EACH FIELD.
2820: #
2821: # +------------------------------------+
2822: # I FCODE I
2823: # +------------------------------------+
2824: # I FARGS I
2825: # +------------------------------------+
2826: # I FFDFP I
2827: # +------------------------------------+
2828: # I FFNXT I
2829: # +------------------------------------+
2830: # I FFOFS I
2831: # +------------------------------------+
2832: #
2833: .set ffdfp,fargs+1 # pointer to associated dfblk
2834: .set ffnxt,ffdfp+1 # ptr to next ffblk on chain or zero
2835: .set ffofs,ffnxt+1 # offset (bytes) to field in pdblk
2836: .set ffsi$,ffofs+1 # size of ffblk in words
2837: #
2838: # THE FCODE FIELD POINTS TO THE ROUTINE B$FFC.
2839: #
2840: # FARGS ALWAYS CONTAINS ONE.
2841: #
2842: # FFDFP IS USED TO VERIFY THAT THE CORRECT PROGRAM DEFINED
2843: # DATATYPE IS BEING ACCESSED BY THIS CALL.
2844: # FFDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC
2845: #
2846: # FFOFS IS USED TO SELECT THE APPROPRIATE FIELD. NOTE THAT
2847: # IT IS AN ACTUAL OFFSET (NOT A FIELD NUMBER)
2848: #
2849: # FFNXT IS USED TO POINT TO THE NEXT FFBLK OF THE SAME NAME
2850: # IN THE CASE WHERE THERE ARE SEVERAL FIELDS OF THE SAME
2851: # NAME FOR DIFFERENT DATATYPES. ZERO MARKS THE END OF CHAIN
2852: #page
2853: #
2854: # INTEGER CONSTANT BLOCK (ICBLK)
2855: #
2856: # AN ICBLK IS CREATED FOR EVERY INTEGER REFERENCED OR
2857: # CREATED BY A PROGRAM. NOTE HOWEVER THAT CERTAIN INTERNAL
2858: # INTEGER VALUES ARE STORED AS ADDRESSES (E.G. THE LENGTH
2859: # FIELD IN A STRING CONSTANT BLOCK)
2860: #
2861: # +------------------------------------+
2862: # I ICGET I
2863: # +------------------------------------+
2864: # * ICVAL *
2865: # +------------------------------------+
2866: #
2867: .set icget,0 # ptr to routine b$icl to load int
2868: .set icval,icget+1 # integer value
2869: .set icsi$,icval+cfp$i# size of icblk
2870: #
2871: # THE LENGTH OF THE ICVAL FIELD IS CFP$I.
2872: #page
2873: #
2874: # KEYWORD VARIABLE BLOCK (KVBLK)
2875: #
2876: # A KVBLK IS USED TO REPRESENT A KEYWORD PSEUDO-VARIABLE.
2877: # A KVBLK IS BUILT FOR EACH KEYWORD REFERENCE (KWNAM).
2878: #
2879: # +------------------------------------+
2880: # I KVTYP I
2881: # +------------------------------------+
2882: # I KVVAR I
2883: # +------------------------------------+
2884: # I KVNUM I
2885: # +------------------------------------+
2886: #
2887: .set kvtyp,0 # pointer to dummy routine b$kvt
2888: .set kvvar,kvtyp+1 # pointer to dummy block trbkv
2889: .set kvnum,kvvar+1 # keyword number
2890: .set kvsi$,kvnum+1 # size of kvblk
2891: #
2892: # THE NAME OF A KEYWORD VARIABLE IS REPRESENTED BY A
2893: # BASE POINTER TO THE KVBLK AND AN OFFSET OF KVVAR. THE
2894: # VALUE APPEARS TO BE TRAPPED BY THE POINTER TO TRBKV.
2895: #page
2896: #
2897: # NAME BLOCK (NMBLK)
2898: #
2899: # A NAME BLOCK IS USED WHEREVER A NAME MUST BE STORED AS
2900: # A VALUE FOLLOWING USE OF THE UNARY DOT OPERATOR.
2901: #
2902: # +------------------------------------+
2903: # I NMTYP I
2904: # +------------------------------------+
2905: # I NMBAS I
2906: # +------------------------------------+
2907: # I NMOFS I
2908: # +------------------------------------+
2909: #
2910: .set nmtyp,0 # ptr to routine b$nml to load name
2911: .set nmbas,nmtyp+1 # base pointer for variable
2912: .set nmofs,nmbas+1 # offset for variable
2913: .set nmsi$,nmofs+1 # size of nmblk
2914: #
2915: # THE ACTUAL FIELD REPRESENTING THE CONTENTS OF THE NAME
2916: # IS FOUND NMOFS BYTES PAST THE ADDRESS IN NMBAS.
2917: #
2918: # THE NAME IS SPLIT INTO BASE AND OFFSET FORM TO AVOID
2919: # CREATION OF A POINTER INTO THE MIDDLE OF A BLOCK WHICH
2920: # COULD NOT BE HANDLED PROPERLY BY THE GARBAGE COLLECTOR.
2921: #
2922: # A NAME MAY BE BUILT FOR ANY VARIABLE (SEE SECTION ON
2923: # REPRESENTATIONS OF VARIABLES) THIS INCLUDES THE
2924: # CASES OF PSEUDO-VARIABLES.
2925: #page
2926: #
2927: # PATTERN BLOCK, NO PARAMETERS (P0BLK)
2928: #
2929: # A P0BLK IS USED TO REPRESENT PATTERN NODES WHICH DO
2930: # NOT REQUIRE THE USE OF ANY PARAMETER VALUES.
2931: #
2932: # +------------------------------------+
2933: # I PCODE I
2934: # +------------------------------------+
2935: # I PTHEN I
2936: # +------------------------------------+
2937: #
2938: .set pcode,0 # ptr to match routine (p$xxx)
2939: .set pthen,pcode+1 # pointer to subsequent node
2940: .set pasi$,pthen+1 # size of p0blk
2941: #
2942: # PTHEN POINTS TO THE PATTERN BLOCK FOR THE SUBSEQUENT
2943: # NODE TO BE MATCHED. THIS IS A POINTER TO THE PATTERN
2944: # BLOCK NDNTH IF THERE IS NO SUBSEQUENT (END OF PATTERN)
2945: #
2946: # PCODE IS A POINTER TO THE MATCH ROUTINE FOR THE NODE.
2947: #page
2948: #
2949: # PATTERN BLOCK (ONE PARAMETER)
2950: #
2951: # A P1BLK IS USED TO REPRESENT PATTERN NODES WHICH
2952: # REQUIRE ONE PARAMETER VALUE.
2953: #
2954: # +------------------------------------+
2955: # I PCODE I
2956: # +------------------------------------+
2957: # I PTHEN I
2958: # +------------------------------------+
2959: # I PARM1 I
2960: # +------------------------------------+
2961: #
2962: .set parm1,pthen+1 # first parameter value
2963: .set pbsi$,parm1+1 # size of p1blk in words
2964: #
2965: # SEE P0BLK FOR DEFINITIONS OF PCODE, PTHEN
2966: #
2967: # PARM1 CONTAINS A PARAMETER VALUE USED IN MATCHING THE
2968: # NODE. FOR EXAMPLE, IN A LEN PATTERN, IT IS THE INTEGER
2969: # ARGUMENT TO LEN. THE DETAILS OF THE USE OF THE PARAMETER
2970: # FIELD ARE INCLUDED IN THE DESCRIPTION OF THE INDIVIDUAL
2971: # MATCH ROUTINES. PARM1 IS ALWAYS AN ADDRESS POINTER WHICH
2972: # IS PROCESSED BY THE GARBAGE COLLECTOR.
2973: #page
2974: #
2975: # PATTERN BLOCK (TWO PARAMETERS)
2976: #
2977: # A P2BLK IS USED TO REPRESENT PATTERN NODES WHICH
2978: # REQUIRE TWO PARAMETER VALUES.
2979: #
2980: # +------------------------------------+
2981: # I PCODE I
2982: # +------------------------------------+
2983: # I PTHEN I
2984: # +------------------------------------+
2985: # I PARM1 I
2986: # +------------------------------------+
2987: # I PARM2 I
2988: # +------------------------------------+
2989: #
2990: .set parm2,parm1+1 # second parameter value
2991: .set pcsi$,parm2+1 # size of p2blk in words
2992: #
2993: # SEE P1BLK FOR DEFINITIONS OF PCODE, PTHEN, PARM1
2994: #
2995: # PARM2 IS A PARAMETER WHICH PERFORMS THE SAME SORT OF
2996: # FUNCTION AS PARM1 (SEE DESCRIPTION OF P1BLK).
2997: #
2998: # PARM2 IS A NON-RELOCATABLE FIELD AND IS NOT
2999: # PROCESSED BY THE GARBAGE COLLECTOR. ACCORDINGLY, IT MAY
3000: # NOT CONTAIN A POINTER TO A BLOCK IN DYNAMIC MEMORY.
3001: #page
3002: #
3003: # PROGRAM-DEFINED DATATYPE BLOCK
3004: #
3005: # A PDBLK REPRESENTS THE DATA ITEM FORMED BY A CALL TO A
3006: # DATATYPE FUNCTION AS DEFINED BY THE SYSTEM FUNCTION DATA.
3007: #
3008: # +------------------------------------+
3009: # I PDTYP I
3010: # +------------------------------------+
3011: # I IDVAL I
3012: # +------------------------------------+
3013: # I PDDFP I
3014: # +------------------------------------+
3015: # / /
3016: # / PDFLD /
3017: # / /
3018: # +------------------------------------+
3019: #
3020: .set pdtyp,0 # ptr to dummy routine b$pdt
3021: .set pddfp,idval+1 # ptr to associated dfblk
3022: .set pdfld,pddfp+1 # start of field value pointers
3023: .set pdfof,dffld-pdfld# difference in offset to field ptrs
3024: .set pdsi$,pdfld # size of standard fields in pdblk
3025: .set pddfs,dfsi$-pdsi$# difference in dfblk, pdblk sizes
3026: #
3027: # THE PDDFP POINTER MAY BE USED TO DETERMINE THE DATATYPE
3028: # AND THE NAMES OF THE FIELDS IF REQUIRED. THE DFBLK ALSO
3029: # CONTAINS THE LENGTH OF THE PDBLK IN BYTES (FIELD DFPDL).
3030: # PDDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC
3031: #
3032: # PDFLD VALUES ARE STORED IN ORDER FROM LEFT TO RIGHT.
3033: # THEY CONTAIN VALUES OR POINTERS TO TRBLK CHAINS.
3034: #page
3035: #
3036: # PROGRAM DEFINED FUNCTION BLOCK (PFBLK)
3037: #
3038: # A PFBLK IS CREATED FOR EACH CALL TO THE DEFINE FUNCTION
3039: # AND A POINTER TO THE PFBLK PLACED IN THE PROPER VRBLK.
3040: #
3041: # +------------------------------------+
3042: # I FCODE I
3043: # +------------------------------------+
3044: # I FARGS I
3045: # +------------------------------------+
3046: # I PFLEN I
3047: # +------------------------------------+
3048: # I PFVBL I
3049: # +------------------------------------+
3050: # I PFNLO I
3051: # +------------------------------------+
3052: # I PFCOD I
3053: # +------------------------------------+
3054: # I PFCTR I
3055: # +------------------------------------+
3056: # I PFRTR I
3057: # +------------------------------------+
3058: # / /
3059: # / PFARG /
3060: # / /
3061: # +------------------------------------+
3062: #
3063: .set pflen,fargs+1 # length of pfblk in bytes
3064: .set pfvbl,pflen+1 # pointer to vrblk for function name
3065: .set pfnlo,pfvbl+1 # number of locals
3066: .set pfcod,pfnlo+1 # ptr to cdblk for first statement
3067: .set pfctr,pfcod+1 # trblk ptr if call traced else 0
3068: .set pfrtr,pfctr+1 # trblk ptr if return traced else 0
3069: .set pfarg,pfrtr+1 # vrblk ptrs for arguments and locals
3070: .set pfagb,pfarg-1 # offset behind pfarg for arg, local
3071: .set pfsi$,pfarg # number of standard fields in pfblk
3072: #
3073: # THE FCODE FIELD POINTS TO THE ROUTINE B$PFC.
3074: #
3075: # PFARG IS STORED IN THE FOLLOWING ORDER.
3076: #
3077: # ARGUMENTS (LEFT TO RIGHT)
3078: # LOCALS (LEFT TO RIGHT)
3079: #page
3080: #
3081: # REAL CONSTANT BLOCK (RCBLK)
3082: #
3083: # AN RCBLK IS CREATED FOR EVERY REAL REFERENCED OR
3084: # CREATED BY A PROGRAM.
3085: #
3086: # +------------------------------------+
3087: # I RCGET I
3088: # +------------------------------------+
3089: # * RCVAL *
3090: # +------------------------------------+
3091: #
3092: .set rcget,0 # ptr to routine b$rcl to load real
3093: .set rcval,rcget+1 # real value
3094: .set rcsi$,rcval+cfp$r# size of rcblk
3095: #
3096: # THE LENGTH OF THE RCVAL FIELD IS CFP$R.
3097: #page
3098: #
3099: # STRING CONSTANT BLOCK (SCBLK)
3100: #
3101: # AN SCBLK IS BUILT FOR EVERY STRING REFERENCED OR CREATED
3102: # BY A PROGRAM.
3103: #
3104: # +------------------------------------+
3105: # I SCGET I
3106: # +------------------------------------+
3107: # I SCLEN I
3108: # +------------------------------------+
3109: # / /
3110: # / SCHAR /
3111: # / /
3112: # +------------------------------------+
3113: #
3114: .set scget,0 # ptr to routine b$scl to load string
3115: .set sclen,scget+1 # length of string in characters
3116: .set schar,sclen+1 # characters of string
3117: .set scsi$,schar # size of standard fields in scblk
3118: #
3119: # THE CHARACTERS OF THE STRING ARE STORED LEFT JUSTIFIED.
3120: # THE FINAL WORD IS PADDED ON THE RIGHT WITH ZEROS.
3121: # (I.E. THE CHARACTER WHOSE INTERNAL CODE IS ZERO).
3122: #
3123: # THE VALUE OF SCLEN MAY NOT EXCEED MXLEN. THIS ENSURES
3124: # THAT CHARACTER OFFSETS (E.G. THE PATTERN MATCH CURSOR)
3125: # CAN BE CORRECTLY PROCESSED BY THE GARBAGE COLLECTOR.
3126: #
3127: # NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING
3128: # IS GIVEN IN BYTES BY CFP$F AND THAT THIS VALUE IS
3129: # AUTOMATICALLY ALLOWED FOR IN PLC, PSC.
3130: # NOTE THAT FOR A SPITBOL SCBLK, THE VALUE OF CFP$F
3131: # IS GIVEN BY CFP$B*SCHAR.
3132: #page
3133: #
3134: # SIMPLE EXPRESSION BLOCK (SEBLK)
3135: #
3136: # AN SEBLK IS USED TO REPRESENT AN EXPRESSION OF THE FORM
3137: # *(NATURAL VARIABLE). ALL OTHER EXPRESSIONS ARE EXBLKS.
3138: #
3139: # +------------------------------------+
3140: # I SETYP I
3141: # +------------------------------------+
3142: # I SEVAR I
3143: # +------------------------------------+
3144: #
3145: .set setyp,0 # ptr to routine b$sel to load expr
3146: .set sevar,setyp+1 # ptr to vrblk for variable
3147: .set sesi$,sevar+1 # length of seblk in words
3148: #page
3149: #
3150: # STANDARD VARIABLE BLOCK (SVBLK)
3151: #
3152: # AN SVBLK IS ASSEMBLED IN THE CONSTANT SECTION FOR EACH
3153: # VARIABLE WHICH SATISFIES ONE OF THE FOLLOWING CONDITIONS.
3154: #
3155: # 1) IT IS THE NAME OF A SYSTEM FUNCTION
3156: # 2) IT HAS AN INITIAL VALUE
3157: # 3) IT HAS A KEYWORD ASSOCIATION
3158: # 4) IT HAS A STANDARD I/O ASSOCIATION
3159: # 6) IT HAS A STANDARD LABEL ASSOCIATION
3160: #
3161: # IF VRBLKS ARE CONSTRUCTED FOR ANY OF THESE VARIABLES,
3162: # THEN THE VRSVP FIELD POINTS TO THE SVBLK (SEE VRBLK)
3163: #
3164: # +------------------------------------+
3165: # I SVBIT I
3166: # +------------------------------------+
3167: # I SVLEN I
3168: # +------------------------------------+
3169: # I SVCHS I
3170: # +------------------------------------+
3171: # I SVKNM I
3172: # +------------------------------------+
3173: # I SVFNC I
3174: # +------------------------------------+
3175: # I SVNAR I
3176: # +------------------------------------+
3177: # I SVLBL I
3178: # +------------------------------------+
3179: # I SVVAL I
3180: # +------------------------------------+
3181: #page
3182: #
3183: # STANDARD VARIABLE BLOCK (CONTINUED)
3184: #
3185: .set svbit,0 # bit string indicating attributes
3186: .set svlen,1 # (=sclen) length of name in chars
3187: .set svchs,2 # (=schar) characters of name
3188: .set svsi$,2 # number of standard fields in svblk
3189: .set svpre,1 # set if preevaluation permitted
3190: .set svffc,svpre+svpre# set on if fast call permitted
3191: .set svckw,svffc+svffc# set on if keyword value constant
3192: .set svprd,svckw+svckw# set on if predicate function
3193: .set svnbt,4 # number of bits to right of svknm
3194: .set svknm,svprd+svprd# set on if keyword association
3195: .set svfnc,svknm+svknm# set on if system function
3196: .set svnar,svfnc+svfnc# set on if system function
3197: .set svlbl,svnar+svnar# set on if system label
3198: .set svval,svlbl+svlbl# set on if predefined value
3199: #
3200: # NOTE THAT THE LAST FIVE BITS CORRESPOND IN ORDER
3201: # TO THE FIELDS WHICH ARE PRESENT (SEE PROCEDURE GTNVR).
3202: #
3203: # THE FOLLOWING DEFINITIONS ARE USED IN THE SVBLK TABLE
3204: #
3205: .set svfnf,svfnc+svnar# function with no fast call
3206: .set svfnn,svfnf+svffc# function with fast call, no preeval
3207: .set svfnp,svfnn+svpre# function allowing preevaluation
3208: .set svfpr,svfnn+svprd# predicate function
3209: .set svfnk,svfnn+svknm# no preeval func + keyword
3210: .set svkwv,svknm+svval# keyword + value
3211: .set svkwc,svckw+svknm# keyword with constant value
3212: .set svkvc,svkwv+svckw# constant keyword + value
3213: .set svkvl,svkvc+svlbl# constant keyword + value + label
3214: .set svfpk,svfnp+svkvc# preeval fcn + const keywd + val
3215: #
3216: # THE SVPRE BIT ALLOWS THE COMPILER TO PREEVALUATE A CALL
3217: # TO THE ASSOCIATED SYSTEM FUNCTION IF ALL THE ARGUMENTS
3218: # ARE THEMSELVES CONSTANTS. FUNCTIONS IN THIS CATEGORY
3219: # MUST HAVE NO SIDE EFFECTS AND MUST NEVER CAUSE FAILURE.
3220: # THE CALL MAY GENERATE AN ERROR CONDITION.
3221: #
3222: # THE SVFFC BIT ALLOWS THE COMPILER TO GENERATE THE SPECIAL
3223: # FAST CALL AFTER ADJUSTING THE NUMBER OF ARGUMENTS. ONLY
3224: # THE ITEM AND APPLY FUNCTIONS FALL OUTSIDE THIS CATEGORY.
3225: #
3226: # THE SVCKW BIT IS SET IF THE ASSOCIATED KEYWORD VALUE IS
3227: # A CONSTANT, THUS ALLOWING PREEVALUATION FOR A VALUE CALL.
3228: #
3229: # THE SVPRD BIT IS SET ON FOR ALL PREDICATE FUNCTIONS TO
3230: # ENABLE THE SPECIAL CONCATENATION CODE OPTIMIZATION.
3231: #page
3232: #
3233: # SVBLK (CONTINUED)
3234: #
3235: # SVKNM KEYWORD NUMBER
3236: #
3237: # SVKNM IS PRESENT ONLY FOR A STANDARD KEYWORD ASSOC.
3238: # IT CONTAINS A KEYWORD NUMBER AS DEFINED BY THE
3239: # KEYWORD NUMBER TABLE GIVEN LATER ON.
3240: #
3241: # SVFNC SYSTEM FUNCTION POINTER
3242: #
3243: # SVFNC IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC.
3244: # IT IS A POINTER TO THE ACTUAL CODE FOR THE SYSTEM
3245: # FUNCTION. THE GENERATED CODE FOR A FAST CALL IS A
3246: # POINTER TO THE SVFNC FIELD OF THE SVBLK FOR THE
3247: # FUNCTION. THE VRFNC FIELD OF THE VRBLK POINTS TO
3248: # THIS SAME FIELD, IN WHICH CASE, IT SERVES AS THE
3249: # FCODE FIELD FOR THE FUNCTION CALL.
3250: #
3251: # SVNAR NUMBER OF FUNCTION ARGUMENTS
3252: #
3253: # SVNAR IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC.
3254: # IT IS THE NUMBER OF ARGUMENTS REQUIRED FOR A CALL
3255: # TO THE SYSTEM FUNCTION. THE COMPILER USES THIS
3256: # VALUE TO ADJUST THE NUMBER OF ARGUMENTS IN A FAST
3257: # CALL AND IN THE CASE OF A FUNCTION CALLED THROUGH
3258: # THE VRFNC FIELD OF THE VRBLK, THE SVNAR FIELD
3259: # SERVES AS THE FARGS FIELD FOR O$FNC. A SPECIAL
3260: # CASE OCCURS IF THIS VALUE IS SET TO 999. THIS IS
3261: # USED TO INDICATE THAT THE FUNCTION HAS A VARIABLE
3262: # NUMBER OF ARGUMENTS AND CAUSES O$FNC TO PASS CONTROL
3263: # WITHOUT ADJUSTING THE ARGUMENT COUNT. THE ONLY
3264: # PREDEFINED FUNCTIONS USING THIS ARE APPLY AND ITEM.
3265: #
3266: # SVLBL SYSTEM LABEL POINTER
3267: #
3268: # SVLBL IS PRESENT ONLY FOR A STANDARD LABEL ASSOC.
3269: # IT IS A POINTER TO A SYSTEM LABEL ROUTINE (L$XXX).
3270: # THE VRLBL FIELD OF THE CORRESPONDING VRBLK POINTS TO
3271: # THE SVLBL FIELD OF THE SVBLK.
3272: #
3273: # SVVAL SYSTEM VALUE POINTER
3274: #
3275: # SVVAL IS PRESENT ONLY FOR A STANDARD VALUE.
3276: # IT IS A POINTER TO THE PATTERN NODE (NDXXX) WHICH
3277: # IS THE STANDARD INITIAL VALUE OF THE VARIABLE.
3278: # THIS VALUE IS COPIED TO THE VRVAL FIELD OF THE VRBLK
3279: #page
3280: #
3281: # SVBLK (CONTINUED)
3282: #
3283: # KEYWORD NUMBER TABLE
3284: #
3285: # THE FOLLOWING TABLE GIVES SYMBOLIC NAMES FOR KEYWORD
3286: # NUMBERS. THESE VALUES ARE STORED IN THE SVKNM FIELD OF
3287: # SVBLKS AND IN THE KVNUM FIELD OF KVBLKS. SEE ALSO
3288: # PROCEDURES ASIGN, ACESS AND KWNAM.
3289: #
3290: # UNPROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
3291: #
3292: .set k$abe,0 # abend
3293: .set k$anc,k$abe+cfp$b# anchor
3294: .set k$cas,k$anc+cfp$b# case
3295: .set k$cod,k$cas+cfp$b# code
3296: .set k$dmp,k$cod+cfp$b# dump
3297: .set k$erl,k$dmp+cfp$b# errlimit
3298: .set k$ert,k$erl+cfp$b# errtype
3299: .set k$ftr,k$ert+cfp$b# ftrace
3300: .set k$inp,k$ftr+cfp$b# input
3301: .set k$mxl,k$inp+cfp$b# maxlength
3302: .set k$oup,k$mxl+cfp$b# output
3303: .set k$pfl,k$oup+cfp$b# profile
3304: .set k$tra,k$pfl+cfp$b# trace
3305: .set k$trm,k$tra+cfp$b# trim
3306: #
3307: # PROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
3308: #
3309: .set k$fnc,k$trm+cfp$b# fnclevel
3310: .set k$lst,k$fnc+cfp$b# lastno
3311: .set k$stn,k$lst+cfp$b# stno
3312: #
3313: # KEYWORDS WITH CONSTANT PATTERN VALUES
3314: #
3315: .set k$abo,k$stn+cfp$b# abort
3316: .set k$arb,k$abo+pasi$# arb
3317: .set k$bal,k$arb+pasi$# bal
3318: .set k$fal,k$bal+pasi$# fail
3319: .set k$fen,k$fal+pasi$# fence
3320: .set k$rem,k$fen+pasi$# rem
3321: .set k$suc,k$rem+pasi$# succeed
3322: #page
3323: #
3324: # KEYWORD NUMBER TABLE (CONTINUED)
3325: #
3326: # SPECIAL KEYWORDS
3327: #
3328: .set k$alp,k$suc+1 # alphabet
3329: .set k$rtn,k$alp+1 # rtntype
3330: .set k$stc,k$rtn+1 # stcount
3331: .set k$etx,k$stc+1 # errtext
3332: .set k$stl,k$etx+1 # stlimit
3333: #
3334: # RELATIVE OFFSETS OF SPECIAL KEYWORDS
3335: #
3336: .set k$$al,k$alp-k$alp# alphabet
3337: .set k$$rt,k$rtn-k$alp# rtntype
3338: .set k$$sc,k$stc-k$alp# stcount
3339: .set k$$et,k$etx-k$alp# errtext
3340: .set k$$sl,k$stl-k$alp# stlimit
3341: #
3342: # SYMBOLS USED IN ASIGN AND ACESS PROCEDURES
3343: #
3344: .set k$p$$,k$fnc # first protected keyword
3345: .set k$v$$,k$abo # first keyword with constant value
3346: .set k$s$$,k$alp # first keyword with special acess
3347: #page
3348: #
3349: # FORMAT OF A TABLE BLOCK (TBBLK)
3350: #
3351: # A TABLE BLOCK IS USED TO REPRESENT A TABLE VALUE.
3352: # IT IS BUILT BY A CALL TO THE TABLE OR CONVERT FUNCTIONS.
3353: #
3354: # +------------------------------------+
3355: # I TBTYP I
3356: # +------------------------------------+
3357: # I IDVAL I
3358: # +------------------------------------+
3359: # I TBLEN I
3360: # +------------------------------------+
3361: # +------------------------------------+
3362: # I TBINV I
3363: # +------------------------------------+
3364: # / /
3365: # / TBBUK /
3366: # / /
3367: # +------------------------------------+
3368: #
3369: .set tbtyp,0 # pointer to dummy routine b$tbt
3370: .set tblen,offs2 # length of tbblk in bytes
3371: .set tbinv,offs3 # default initial lookup value
3372: .set tbbuk,tbinv+1 # start of hash bucket pointers
3373: .set tbsi$,tbbuk # size of standard fields in tbblk
3374: .set tbnbk,11 # default no. of buckets
3375: #
3376: # THE TABLE BLOCK IS A HASH TABLE WHICH POINTS TO CHAINS
3377: # OF TABLE ELEMENT BLOCKS REPRESENTING THE ELEMENTS
3378: # IN THE TABLE WHICH HASH INTO THE SAME BUCKET.
3379: #
3380: # TBBUK ENTRIES EITHER POINT TO THE FIRST TEBLK ON THE
3381: # CHAIN OR THEY POINT TO THE TBBLK ITSELF TO INDICATE THE
3382: # END OF THE CHAIN.
3383: #page
3384: #
3385: # TABLE ELEMENT BLOCK (TEBLK)
3386: #
3387: # A TABLE ELEMENT IS USED TO REPRESENT A SINGLE ENTRY IN
3388: # A TABLE (SEE DESCRIPTION OF TBBLK FORMAT FOR HASH TABLE)
3389: #
3390: # +------------------------------------+
3391: # I TETYP I
3392: # +------------------------------------+
3393: # I TESUB I
3394: # +------------------------------------+
3395: # I TEVAL I
3396: # +------------------------------------+
3397: # I TENXT I
3398: # +------------------------------------+
3399: #
3400: .set tetyp,0 # pointer to dummy routine b$tet
3401: .set tesub,tetyp+1 # subscript value
3402: .set teval,tesub+1 # (=vrval) table element value
3403: .set tenxt,teval+1 # link to next teblk
3404: # SEE S$CNV WHERE RELATION IS ASSUMED WITH TENXT AND TBBUK
3405: .set tesi$,tenxt+1 # size of teblk in words
3406: #
3407: # TENXT POINTS TO THE NEXT TEBLK ON THE HASH CHAIN FROM THE
3408: # TBBUK CHAIN FOR THIS HASH INDEX. AT THE END OF THE CHAIN,
3409: # TENXT POINTS BACK TO THE START OF THE TBBLK.
3410: #
3411: # TEVAL CONTAINS A DATA POINTER OR A TRBLK POINTER.
3412: #
3413: # TESUB CONTAINS A DATA POINTER.
3414: #page
3415: #
3416: # TRAP BLOCK (TRBLK)
3417: #
3418: # A TRAP BLOCK IS USED TO REPRESENT A TRACE OR INPUT OR
3419: # OUTPUT ASSOCIATION IN RESPONSE TO A CALL TO THE TRACE
3420: # INPUT OR OUTPUT SYSTEM FUNCTIONS. SEE BELOW FOR DETAILS
3421: #
3422: # +------------------------------------+
3423: # I TRIDN I
3424: # +------------------------------------+
3425: # I TRTYP I
3426: # +------------------------------------+
3427: # I TRVAL OR TRLBL OR TRNXT OR TRKVR I
3428: # +------------------------------------+
3429: # I TRTAG OR TRTER OR TRTRF I
3430: # +------------------------------------+
3431: # I TRFNC OR TRFPT I
3432: # +------------------------------------+
3433: #
3434: .set tridn,0 # pointer to dummy routine b$trt
3435: .set trtyp,tridn+1 # trap type code
3436: .set trval,trtyp+1 # value of trapped variable (=vrval)
3437: .set trnxt,trval # ptr to next trblk on trblk chain
3438: .set trlbl,trval # ptr to actual label (traced label)
3439: .set trkvr,trval # vrblk pointer for keyword trace
3440: .set trtag,trval+1 # trace tag
3441: .set trter,trtag # ptr to terminal vrblk or null
3442: .set trtrf,trtag # ptr to trblk holding fcblk ptr
3443: .set trfnc,trtag+1 # trace function vrblk (zero if none)
3444: .set trfpt,trfnc # fcblk ptr for sysio
3445: .set trsi$,trfnc+1 # number of words in trblk
3446: #
3447: .set trtin,0 # trace type for input association
3448: .set trtac,trtin+1 # trace type for access trace
3449: .set trtvl,trtac+1 # trace type for value trace
3450: .set trtou,trtvl+1 # trace type for output association
3451: .set trtfc,trtou+1 # trace type for fcblk identification
3452: #page
3453: #
3454: # TRAP BLOCK (CONTINUED)
3455: #
3456: # VARIABLE INPUT ASSOCIATION
3457: #
3458: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3459: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3460: # OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3461: # CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3462: #
3463: # TRTYP IS SET TO TRTIN
3464: # TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3465: # TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS
3466: # FOR INPUT, TERMINAL, ELSE IT IS NULL.
3467: # TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS
3468: # TO AN FCBLK USED FOR I/O ASSOCIATION.
3469: # TRFPT IS THE FCBLK PTR RETURNED BY SYSIO.
3470: #
3471: # VARIABLE ACCESS TRACE ASSOCIATION
3472: #
3473: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3474: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3475: # OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3476: # CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3477: #
3478: # TRTYP IS SET TO TRTAC
3479: # TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3480: # TRTAG IS THE TRACE TAG (0 IF NONE)
3481: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3482: #
3483: # VARIABLE VALUE TRACE ASSOCIATION
3484: #
3485: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3486: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3487: # OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3488: # CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3489: #
3490: # TRTYP IS SET TO TRTVL
3491: # TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3492: # TRTAG IS THE TRACE TAG (0 IF NONE)
3493: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3494: #page
3495: # TRAP BLOCK (CONTINUED)
3496: #
3497: # VARIABLE OUTPUT ASSOCIATION
3498: #
3499: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3500: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
3501: # OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3502: # CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
3503: #
3504: # TRTYP IS SET TO TRTOU
3505: # TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
3506: # TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS
3507: # FOR OUTPUT, TERMINAL, ELSE IT IS NULL.
3508: # TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS
3509: # TO AN FCBLK USED FOR I/O ASSOCIATION.
3510: # TRFPT IS THE FCBLK PTR RETURNED BY SYSIO.
3511: #
3512: # FUNCTION CALL TRACE
3513: #
3514: # THE PFCTR FIELD OF THE CORRESPONDING PFBLK IS SET
3515: # TO POINT TO A TRBLK.
3516: #
3517: # TRTYP IS SET TO TRTIN
3518: # TRNXT IS ZERO
3519: # TRTAG IS THE TRACE TAG (0 IF NONE)
3520: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3521: #
3522: # FUNCTION RETURN TRACE
3523: #
3524: # THE PFRTR FIELD OF THE CORRESPONDING PFBLK IS SET
3525: # TO POINT TO A TRBLK
3526: #
3527: # TRTYP IS SET TO TRTIN
3528: # TRNXT IS ZERO
3529: # TRTAG IS THE TRACE TAG (0 IF NONE)
3530: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3531: #
3532: # LABEL TRACE
3533: #
3534: # THE VRLBL OF THE VRBLK FOR THE LABEL IS
3535: # CHANGED TO POINT TO A TRBLK AND THE VRTRA FIELD IS
3536: # SET TO B$VRT TO ACTIVATE THE CHECK.
3537: #
3538: # TRTYP IS SET TO TRTIN
3539: # TRLBL POINTS TO THE ACTUAL LABEL (CDBLK) VALUE
3540: # TRTAG IS THE TRACE TAG (0 IF NONE)
3541: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3542: #page
3543: #
3544: # TRAP BLOCK (CONTINUED)
3545: #
3546: # KEYWORD TRACE
3547: #
3548: # KEYWORDS WHICH CAN BE TRACED POSSESS A UNIQUE
3549: # LOCATION WHICH IS ZERO IF THERE IS NO TRACE AND
3550: # POINTS TO A TRBLK IF THERE IS A TRACE. THE LOCATIONS
3551: # ARE AS FOLLOWS.
3552: #
3553: # R$ERT ERRTYPE
3554: # R$FNC FNCLEVEL
3555: # R$STC STCOUNT
3556: #
3557: # THE FORMAT OF THE TRBLK IS AS FOLLOWS.
3558: #
3559: # TRTYP IS SET TO TRTIN
3560: # TRKVR IS A POINTER TO THE VRBLK FOR THE KEYWORD
3561: # TRTAG IS THE TRACE TAG (0 IF NONE)
3562: # TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
3563: #
3564: # INPUT/OUTPUT FILE ARG1 TRAP BLOCK
3565: #
3566: # THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
3567: # INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE OF
3568: # A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
3569: # CONTAIN =B$VRA AND =B$VRV. THIS TRAP BLOCK IS USED
3570: # TO HOLD A POINTER TO THE FCBLK WHICH AN
3571: # IMPLEMENTATION MAY REQUEST TO HOLD INFORMATION
3572: # ABOUT A FILE.
3573: #
3574: # TRTYP IS SET TO TRTFC
3575: # TRNEXT POINTS TO NEXT TRBLK OR TRVAL IS VARIABLE VAL
3576: # TRFNM IS 0
3577: # TRFPT IS THE FCBLK POINTER.
3578: #
3579: # NOTE THAT WHEN MULTIPLE TRAPS ARE SET ON A VARIABLE
3580: # THE ORDER IS IN ASCENDING VALUE OF TRTYP FIELD.
3581: #
3582: # INPUT ASSOCIATION (IF PRESENT)
3583: # ACCESS TRACE (IF PRESENT)
3584: # VALUE TRACE (IF PRESENT)
3585: # OUTPUT ASSOCIATION (IF PRESENT)
3586: #
3587: # THE ACTUAL VALUE OF THE VARIABLE IS STORED IN THE TRVAL
3588: # FIELD OF THE LAST TRBLK ON THE CHAIN.
3589: #
3590: # THIS IMPLEMENTATION DOES NOT PERMIT TRACE OR I/O
3591: # ASSOCIATIONS TO ANY OF THE PSEUDO-VARIABLES.
3592: #page
3593: #
3594: # VECTOR BLOCK (VCBLK)
3595: #
3596: # A VCBLK IS USED TO REPRESENT AN ARRAY VALUE WHICH HAS
3597: # ONE DIMENSION WHOSE LOWER BOUND IS ONE. ALL OTHER ARRAYS
3598: # ARE REPRESENTED BY ARBLKS. A VCBLK IS CREATED BY THE
3599: # SYSTEM FUNCTION ARRAY (S$ARR) WHEN PASSED AN INTEGER ARG.
3600: #
3601: # +------------------------------------+
3602: # I VCTYP I
3603: # +------------------------------------+
3604: # I IDVAL I
3605: # +------------------------------------+
3606: # I VCLEN I
3607: # +------------------------------------+
3608: # I VCVLS I
3609: # +------------------------------------+
3610: #
3611: .set vctyp,0 # pointer to dummy routine b$vct
3612: .set vclen,offs2 # length of vcblk in bytes
3613: .set vcvls,offs3 # start of vector values
3614: .set vcsi$,vcvls # size of standard fields in vcblk
3615: .set vcvlb,vcvls-1 # offset one word behind vcvls
3616: .set vctbd,tbsi$-vcsi$# difference in sizes - see prtvl
3617: #
3618: # VCVLS ARE EITHER DATA POINTERS OR TRBLK POINTERS
3619: #
3620: # THE DIMENSION CAN BE DEDUCED FROM VCLEN.
3621: #page
3622: #
3623: # VARIABLE BLOCK (VRBLK)
3624: #
3625: # A VARIABLE BLOCK IS BUILT IN THE STATIC MEMORY AREA
3626: # FOR EVERY VARIABLE REFERENCED OR CREATED BY A PROGRAM.
3627: #
3628: # NOTE THAT SINCE THESE BLOCKS ONLY OCCUR IN THE STATIC
3629: # REGION, IT IS PERMISSIBLE TO POINT TO ANY WORD IN
3630: # THE BLOCK AND THIS IS USED TO PROVIDE THREE DISTINCT
3631: # ACCESS POINTS FROM THE GENERATED CODE AS FOLLOWS.
3632: #
3633: # 1) POINT TO VRGET (FIRST WORD OF VRBLK) TO LOAD THE
3634: # VALUE OF THE VARIABLE ONTO THE MAIN STACK.
3635: #
3636: # 2) POINT TO VRSTO (SECOND WORD OF VRBLK) TO STORE THE
3637: # TOP STACK ELEMENT AS THE VALUE OF THE VARIABLE.
3638: #
3639: # 3) POINT TO VRTRA (FOURTH WORD OF VRBLK) TO JUMP TO
3640: # THE LABEL ASSOCIATED WITH THE VARIABLE NAME.
3641: #
3642: # +------------------------------------+
3643: # I VRGET I
3644: # +------------------------------------+
3645: # I VRSTO I
3646: # +------------------------------------+
3647: # I VRVAL I
3648: # +------------------------------------+
3649: # I VRTRA I
3650: # +------------------------------------+
3651: # I VRLBL I
3652: # +------------------------------------+
3653: # I VRFNC I
3654: # +------------------------------------+
3655: # I VRNXT I
3656: # +------------------------------------+
3657: # I VRLEN I
3658: # +------------------------------------+
3659: # / /
3660: # / VRCHS = VRSVP /
3661: # / /
3662: # +------------------------------------+
3663: #page
3664: #
3665: # VARIABLE BLOCK (CONTINUED)
3666: #
3667: .set vrget,0 # pointer to routine to load value
3668: .set vrsto,vrget+1 # pointer to routine to store value
3669: .set vrval,vrsto+1 # variable value
3670: .set vrvlo,vrval-vrsto# offset to value from store field
3671: .set vrtra,vrval+1 # pointer to routine to jump to label
3672: .set vrlbl,vrtra+1 # pointer to code for label
3673: .set vrlbo,vrlbl-vrtra# offset to label from transfer field
3674: .set vrfnc,vrlbl+1 # pointer to function block
3675: .set vrnxt,vrfnc+1 # pointer to next vrblk on hash chain
3676: .set vrlen,vrnxt+1 # length of name (or zero)
3677: .set vrchs,vrlen+1 # characters of name (vrlen gt 0)
3678: .set vrsvp,vrlen+1 # ptr to svblk (vrlen eq 0)
3679: .set vrsi$,vrchs+1 # number of standard fields in vrblk
3680: .set vrsof,vrlen-sclen# offset to dummy scblk for name
3681: .set vrsvo,vrsvp-vrsof# pseudo-offset to vrsvp field
3682: #
3683: # VRGET = B$VRL IF NOT INPUT ASSOCIATED OR ACCESS TRACED
3684: # VRGET = B$VRA IF INPUT ASSOCIATED OR ACCESS TRACED
3685: #
3686: # VRSTO = B$VRS IF NOT OUTPUT ASSOCIATED OR VALUE TRACED
3687: # VRSTO = B$VRV IF OUTPUT ASSOCIATED OR VALUE TRACED
3688: # VRSTO = B$VRE IF VALUE IS PROTECTED PATTERN VALUE
3689: #
3690: # VRVAL POINTS TO THE APPROPRIATE VALUE UNLESS THE
3691: # VARIABLE IS I/O/TRACE ASSOCIATED IN WHICH CASE, VRVAL
3692: # POINTS TO AN APPROPRIATE TRBLK (TRAP BLOCK) CHAIN.
3693: #
3694: # VRTRA = B$VRG IF THE LABEL IS NOT TRACED
3695: # VRTRA = B$VRT IF THE LABEL IS TRACED
3696: #
3697: # VRLBL POINTS TO A CDBLK IF THERE IS A LABEL
3698: # VRLBL POINTS TO THE SVBLK SVLBL FIELD FOR A SYSTEM LABEL
3699: # VRLBL POINTS TO STNDL FOR AN UNDEFINED LABEL
3700: # VRLBL POINTS TO A TRBLK IF THE LABEL IS TRACED
3701: #
3702: # VRFNC POINTS TO A FFBLK FOR A FIELD FUNCTION
3703: # VRFNC POINTS TO A DFBLK FOR A DATATYPE FUNCTION
3704: # VRFNC POINTS TO A PFBLK FOR A PROGRAM DEFINED FUNCTION
3705: # VRFNC POINTS TO A EFBLK FOR AN EXTERNAL LOADED FUNCTION
3706: # VRFNC POINTS TO SVFNC (SVBLK) FOR A SYSTEM FUNCTION
3707: # VRFNC POINTS TO STNDF IF THE FUNCTION IS UNDEFINED
3708: #
3709: # VRNXT POINTS TO THE NEXT VRBLK ON THIS CHAIN UNLESS
3710: # THIS IS THE END OF THE CHAIN IN WHICH CASE IT IS ZERO.
3711: #
3712: # VRLEN IS THE NAME LENGTH FOR A NON-SYSTEM VARIABLE.
3713: # VRLEN IS ZERO FOR A SYSTEM VARIABLE.
3714: #
3715: # VRCHS IS THE NAME (LJRZ) IF VRLEN IS NON-ZERO.
3716: # VRSVP IS A PTR TO THE SVBLK IF VRLEN IS ZERO.
3717: #page
3718: #
3719: # FORMAT OF A NON-RELOCATABLE EXTERNAL BLOCK (XNBLK)
3720: #
3721: # AN XNBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL)
3722: # DATA VALUE. THE BLOCK CONTAINS NO POINTERS TO OTHER
3723: # RELOCATABLE BLOCKS. AN XNBLK IS USED BY EXTERNAL FUNCTION
3724: # PROCESSING OR POSSIBLY FOR SYSTEM I/O ROUTINES ETC.
3725: # THE MACRO-SYSTEM ITSELF DOES NOT USE XNBLKS.
3726: # THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK.
3727: # SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS.
3728: #
3729: # +------------------------------------+
3730: # I XNTYP I
3731: # +------------------------------------+
3732: # I XNLEN I
3733: # +------------------------------------+
3734: # / /
3735: # / XNDTA /
3736: # / /
3737: # +------------------------------------+
3738: #
3739: .set xntyp,0 # pointer to dummy routine b$xnt
3740: .set xnlen,xntyp+1 # length of xnblk in bytes
3741: .set xndta,xnlen+1 # data words
3742: .set xnsi$,xndta # size of standard fields in xnblk
3743: #
3744: # NOTE THAT THE TERM NON-RELOCATABLE REFERS TO THE CONTENTS
3745: # AND NOT THE BLOCK ITSELF. AN XNBLK CAN BE MOVED AROUND IF
3746: # IT IS BUILT IN THE DYNAMIC MEMORY AREA.
3747: #page
3748: #
3749: # RELOCATABLE EXTERNAL BLOCK (XRBLK)
3750: #
3751: # AN XRBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL)
3752: # DATA VALUE. THE DATA AREA IN THIS BLOCK CONSISTS ONLY
3753: # OF ADDRESS VALUES AND ANY ADDRESSES POINTING INTO THE
3754: # DYNAMIC MEMORY AREA MUST POINT TO THE START OF OTHER
3755: # DATA BLOCKS. SEE ALSO DESCRIPTION OF XNBLK.
3756: # THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK.
3757: # SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS.
3758: #
3759: # +------------------------------------+
3760: # I XRTYP I
3761: # +------------------------------------+
3762: # I XRLEN I
3763: # +------------------------------------+
3764: # / /
3765: # / XRPTR /
3766: # / /
3767: # +------------------------------------+
3768: #
3769: .set xrtyp,0 # pointer to dummy routine b$xrt
3770: .set xrlen,xrtyp+1 # length of xrblk in bytes
3771: .set xrptr,xrlen+1 # start of address pointers
3772: .set xrsi$,xrptr # size of standard fields in xrblk
3773: #page
3774: #
3775: # S$CNV (CONVERT) FUNCTION SWITCH CONSTANTS. THE VALUES
3776: # ARE TIED TO THE ORDER OF THE ENTRIES IN THE SVCTB TABLE
3777: # AND HENCE TO THE BRANCH TABLE IN S$CNV.
3778: #
3779: .set cnvst,8 # max standard type code for convert
3780: .set cnvrt,cnvst+1 # convert code for reals
3781: .set cnvbt,cnvrt+1 # convert code for buffer
3782: .set cnvtt,cnvbt+1 # bsw code for convert
3783: #
3784: # INPUT IMAGE LENGTH
3785: #
3786: .set iniln,132 # default image length for compiler
3787: .set inils,80 # image length if -sequ in effect
3788: #
3789: .set ionmb,2 # name base used for iochn in sysio
3790: .set ionmo,4 # name offset used for iochn in sysio
3791: #
3792: # IN GENERAL, MEANINGFUL MNEMONICS SHOULD BE USED FOR
3793: # OFFSETS. HOWEVER FOR SMALL INTEGERS USED OFTEN IN
3794: # LITERALS THE FOLLOWING GENERAL DEFINITIONS ARE PROVIDED.
3795: #
3796: .set num01,1
3797: .set num02,2
3798: .set num03,3
3799: .set num04,4
3800: .set num05,5
3801: .set num06,6
3802: .set num07,7
3803: .set num08,8
3804: .set num09,9
3805: .set num10,10
3806: .set nini8,998
3807: .set nini9,999
3808: .set thsnd,1000
3809: #page
3810: #
3811: # NUMBERS OF UNDEFINED SPITBOL OPERATORS
3812: #
3813: .set opbun,5 # no. of binary undefined ops
3814: .set opuun,6 # no of unary undefined ops
3815: #
3816: # OFFSETS USED IN PRTSN, PRTMI AND ACESS
3817: #
3818: .set prsnf,13 # offset used in prtsn
3819: .set prtmf,15 # offset to col 15 (prtmi)
3820: .set rilen,120 # buffer length for sysri
3821: #
3822: # CODES FOR STAGES OF PROCESSING
3823: #
3824: .set stgic,0 # initial compile
3825: .set stgxc,stgic+1 # execution compile (code)
3826: .set stgev,stgxc+1 # expression eval during execution
3827: .set stgxt,stgev+1 # execution time
3828: .set stgce,stgxt+1 # initial compile after end line
3829: .set stgxe,stgce+1 # exec. compile after end line
3830: .set stgnd,stgce-stgic# difference in stage after end
3831: .set stgee,stgxe+1 # eval evaluating expression
3832: .set stgno,stgee+1 # number of codes
3833: #page
3834: #
3835: #
3836: # STATEMENT NUMBER PAD COUNT FOR LISTR
3837: #
3838: .set stnpd,8 # statement no. pad count
3839: #
3840: # SYNTAX TYPE CODES
3841: #
3842: # THESE CODES ARE RETURNED FROM THE SCANE PROCEDURE.
3843: #
3844: # THEY ARE SPACED 3 APART FOR THE BENEFIT OF EXPAN.
3845: #
3846: .set t$uop,0 # unary operator
3847: .set t$lpr,t$uop+3 # left paren
3848: .set t$lbr,t$lpr+3 # left bracket
3849: .set t$cma,t$lbr+3 # comma
3850: .set t$fnc,t$cma+3 # function call
3851: .set t$var,t$fnc+3 # variable
3852: .set t$con,t$var+3 # constant
3853: .set t$bop,t$con+3 # binary operator
3854: .set t$rpr,t$bop+3 # right paren
3855: .set t$rbr,t$rpr+3 # right bracket
3856: .set t$col,t$rbr+3 # colon
3857: .set t$smc,t$col+3 # semi-colon
3858: #
3859: # THE FOLLOWING DEFINITIONS ARE USED ONLY IN THE GOTO FIELD
3860: #
3861: .set t$fgo,t$smc+1 # failure goto
3862: .set t$sgo,t$fgo+1 # success goto
3863: #
3864: # THE ABOVE CODES ARE GROUPED SO THAT CODES FOR ELEMENTS
3865: # WHICH CAN LEGITIMATELY IMMEDIATELY PRECEDE A UNARY
3866: # OPERATOR COME FIRST TO FACILITATE OPERATOR SYNTAX CHECK.
3867: #
3868: .set t$uok,t$fnc # last code ok before unary operator
3869: #page
3870: #
3871: # DEFINITIONS OF VALUES FOR EXPAN JUMP TABLE
3872: #
3873: .set t$uo0,t$uop+0 # unary operator, state zero
3874: .set t$uo1,t$uop+1 # unary operator, state one
3875: .set t$uo2,t$uop+2 # unary operator, state two
3876: .set t$lp0,t$lpr+0 # left paren, state zero
3877: .set t$lp1,t$lpr+1 # left paren, state one
3878: .set t$lp2,t$lpr+2 # left paren, state two
3879: .set t$lb0,t$lbr+0 # left bracket, state zero
3880: .set t$lb1,t$lbr+1 # left bracket, state one
3881: .set t$lb2,t$lbr+2 # left bracket, state two
3882: .set t$cm0,t$cma+0 # comma, state zero
3883: .set t$cm1,t$cma+1 # comma, state one
3884: .set t$cm2,t$cma+2 # comma, state two
3885: .set t$fn0,t$fnc+0 # function call, state zero
3886: .set t$fn1,t$fnc+1 # function call, state one
3887: .set t$fn2,t$fnc+2 # function call, state two
3888: .set t$va0,t$var+0 # variable, state zero
3889: .set t$va1,t$var+1 # variable, state one
3890: .set t$va2,t$var+2 # variable, state two
3891: .set t$co0,t$con+0 # constant, state zero
3892: .set t$co1,t$con+1 # constant, state one
3893: .set t$co2,t$con+2 # constant, state two
3894: .set t$bo0,t$bop+0 # binary operator, state zero
3895: .set t$bo1,t$bop+1 # binary operator, state one
3896: .set t$bo2,t$bop+2 # binary operator, state two
3897: .set t$rp0,t$rpr+0 # right paren, state zero
3898: .set t$rp1,t$rpr+1 # right paren, state one
3899: .set t$rp2,t$rpr+2 # right paren, state two
3900: .set t$rb0,t$rbr+0 # right bracket, state zero
3901: .set t$rb1,t$rbr+1 # right bracket, state one
3902: .set t$rb2,t$rbr+2 # right bracket, state two
3903: .set t$cl0,t$col+0 # colon, state zero
3904: .set t$cl1,t$col+1 # colon, state one
3905: .set t$cl2,t$col+2 # colon, state two
3906: .set t$sm0,t$smc+0 # semicolon, state zero
3907: .set t$sm1,t$smc+1 # semicolon, state one
3908: .set t$sm2,t$smc+2 # semicolon, state two
3909: #
3910: .set t$nes,t$sm2+1 # number of entries in branch table
3911: #page
3912: #
3913: # DEFINITION OF OFFSETS USED IN CONTROL CARD PROCESSING
3914: #
3915: .set cc$ca,0 # -case
3916: .set cc$do,cc$ca+1 # -double
3917: .set cc$du,cc$do+1 # -dump
3918: .set cc$ej,cc$du+1 # -eject
3919: .set cc$er,cc$ej+1 # -errors
3920: .set cc$ex,cc$er+1 # -execute
3921: .set cc$fa,cc$ex+1 # -fail
3922: .set cc$li,cc$fa+1 # -list
3923: .set cc$nr,cc$li+1 # -noerrors
3924: .set cc$nx,cc$nr+1 # -noexecute
3925: .set cc$nf,cc$nx+1 # -nofail
3926: .set cc$nl,cc$nf+1 # -nolist
3927: .set cc$no,cc$nl+1 # -noopt
3928: .set cc$np,cc$no+1 # -noprint
3929: .set cc$op,cc$np+1 # -optimise
3930: .set cc$pr,cc$op+1 # -print
3931: .set cc$si,cc$pr+1 # -single
3932: .set cc$sp,cc$si+1 # -space
3933: .set cc$st,cc$sp+1 # -stitl
3934: .set cc$ti,cc$st+1 # -title
3935: .set cc$tr,cc$ti+1 # -trace
3936: .set cc$nc,cc$tr+1 # number of control cards
3937: .set ccnoc,4 # no. of chars included in match
3938: .set ccofs,7 # offset to start of title/subtitle
3939: #page
3940: #
3941: # DEFINITIONS OF STACK OFFSETS USED IN CMPIL PROCEDURE
3942: #
3943: # SEE DESCRIPTION AT START OF CMPIL PROCEDURE FOR DETAILS
3944: # OF USE OF THESE LOCATIONS ON THE STACK.
3945: #
3946: .set cmstm,0 # tree for statement body
3947: .set cmsgo,cmstm+1 # tree for success goto
3948: .set cmfgo,cmsgo+1 # tree for fail goto
3949: .set cmcgo,cmfgo+1 # conditional goto flag
3950: .set cmpcd,cmcgo+1 # previous cdblk pointer
3951: .set cmffp,cmpcd+1 # failure fill in flag for previous
3952: .set cmffc,cmffp+1 # failure fill in flag for current
3953: .set cmsop,cmffc+1 # success fill in offset for previous
3954: .set cmsoc,cmsop+1 # success fill in offset for current
3955: .set cmlbl,cmsoc+1 # ptr to vrblk for current label
3956: .set cmtra,cmlbl+1 # ptr to entry cdblk
3957: #
3958: .set cmnen,cmtra+1 # count of stack entries for cmpil
3959: #
3960: # A FEW CONSTANTS USED BY THE PROFILER
3961: .set pfpd1,8 # pad positions ...
3962: .set pfpd2,20 # ... for profile ...
3963: .set pfpd3,32 # ... printout
3964: .set pf$i2,cfp$i+cfp$i# size of table entry (2 ints)
3965: #
3966: #title s p i t b o l -- constant section
3967: #
3968: # THIS SECTION CONSISTS ENTIRELY OF ASSEMBLED CONSTANTS.
3969: #
3970: # ALL LABEL NAMES ARE FIVE LETTERS. THE ORDER IS
3971: # APPROXIMATELY ALPHABETICAL, BUT IN SOME CASES (ALWAYS
3972: # DOCUMENTED), CONSTANTS MUST BE PLACED IN SOME SPECIAL
3973: # ORDER WHICH MUST NOT BE DISTURBED.
3974: #
3975: # IT MUST ALSO BE REMEMBERED THAT THERE IS A REQUIREMENT
3976: # FOR NO FORWARD REFERENCES WHICH ALSO DISTURBS THE
3977: # ALPHABETICAL ORDER IN SOME CASES.
3978: #
3979: .data 0
3980: #sec # start of constant section
3981: #
3982: # FREE STORE PERCENTAGE (USED BY ALLOC)
3983: #
3984: alfsp: .long e$fsp # free store percentage
3985: #
3986: # BIT CONSTANTS FOR GENERAL USE
3987: #
3988: bits0: .long 0 # all zero bits
3989: bits1: .long 1 # one bit in low order position
3990: bits2: .long 2 # bit in position 2
3991: bits3: .long 4 # bit in position 3
3992: bits4: .long 8 # bit in position 4
3993: bits5: .long 16 # bit in position 5
3994: bits6: .long 32 # bit in position 6
3995: bits7: .long 64 # bit in position 7
3996: bits8: .long 128 # bit in position 8
3997: bits9: .long 256 # bit in position 9
3998: bit10: .long 512 # bit in position 10
3999: bitsm: .long cfp$m # mask for max integer
4000: #
4001: # BIT CONSTANTS FOR SVBLK (SVBIT FIELD) TESTS
4002: #
4003: btfnc: .long svfnc # bit to test for function
4004: btknm: .long svknm # bit to test for keyword number
4005: btlbl: .long svlbl # bit to test for label
4006: btffc: .long svffc # bit to test for fast call
4007: btckw: .long svckw # bit to test for constant keyword
4008: btprd: .long svprd # bit to test for predicate function
4009: btpre: .long svpre # bit to test for preevaluation
4010: btval: .long svval # bit to test for value
4011: #page
4012: #
4013: # LIST OF NAMES USED FOR CONTROL CARD PROCESSING
4014: #
4015: ccnms: .ascii "CASE"
4016: .align 2
4017: .ascii "DOUB"
4018: .align 2
4019: .ascii "DUMP"
4020: .align 2
4021: .ascii "EJEC"
4022: .align 2
4023: .ascii "ERRO"
4024: .align 2
4025: .ascii "EXEC"
4026: .align 2
4027: .ascii "FAIL"
4028: .align 2
4029: .ascii "LIST"
4030: .align 2
4031: .ascii "NOER"
4032: .align 2
4033: .ascii "NOEX"
4034: .align 2
4035: .ascii "NOFA"
4036: .align 2
4037: .ascii "NOLI"
4038: .align 2
4039: .ascii "NOOP"
4040: .align 2
4041: .ascii "NOPR"
4042: .align 2
4043: .ascii "OPTI"
4044: .align 2
4045: .ascii "PRIN"
4046: .align 2
4047: .ascii "SING"
4048: .align 2
4049: .ascii "SPAC"
4050: .align 2
4051: .ascii "STIT"
4052: .align 2
4053: .ascii "TITL"
4054: .align 2
4055: .ascii "TRAC"
4056: .align 2
4057: #
4058: # HEADER MESSAGES FOR DUMPR PROCEDURE (SCBLK FORMAT)
4059: #
4060: dmhdk: .long b$scl # dump of keyword values
4061: .long 22
4062: .ascii "DUMP OF KEYWORD VALUES"
4063: .align 2
4064: #
4065: dmhdv: .long b$scl # dump of natural variables
4066: .long 25
4067: .ascii "DUMP OF NATURAL VARIABLES"
4068: .align 2
4069: #page
4070: #
4071: # MESSAGE TEXT FOR COMPILATION STATISTICS
4072: #
4073: encm1: .long b$scl
4074: .long 10
4075: .ascii "STORE USED"
4076: .align 2
4077: #
4078: encm2: .long b$scl
4079: .long 10
4080: .ascii "STORE LEFT"
4081: .align 2
4082: #
4083: encm3: .long b$scl
4084: .long 11
4085: .ascii "COMP ERRORS"
4086: .align 2
4087: #
4088: encm4: .long b$scl
4089: .long 14
4090: .ascii "COMP TIME-MSEC"
4091: .align 2
4092: #
4093: encm5: .long b$scl # execution suppressed
4094: .long 20
4095: .ascii "EXECUTION SUPPRESSED"
4096: .align 2
4097: #
4098: # STRING CONSTANT FOR ABNORMAL END
4099: #
4100: endab: .long b$scl
4101: .long 12
4102: .ascii "ABNORMAL END"
4103: .align 2
4104: #page
4105: #
4106: # MEMORY OVERFLOW DURING INITIALISATION
4107: #
4108: endmo: .long b$scl
4109: endml: .long 15
4110: .ascii "MEMORY OVERFLOW"
4111: .align 2
4112: #
4113: # STRING CONSTANT FOR MESSAGE ISSUED BY L$END
4114: #
4115: endms: .long b$scl
4116: .long 10
4117: .ascii "NORMAL END"
4118: .align 2
4119: #
4120: # FAIL MESSAGE FOR STACK FAIL SECTION
4121: #
4122: endso: .long b$scl # stack overflow in garbage collector
4123: .long 36
4124: .ascii "STACK OVERFLOW IN GARBAGE COLLECTION"
4125: .align 2
4126: #
4127: # STRING CONSTANT FOR TIME UP
4128: #
4129: endtu: .long b$scl
4130: .long 15
4131: .ascii "ERROR - TIME UP"
4132: .align 2
4133: #page
4134: #
4135: # STRING CONSTANT FOR ERROR MESSAGE (ERROR SECTION)
4136: #
4137: ermms: .long b$scl # error
4138: .long 5
4139: .ascii "ERROR"
4140: .align 2
4141: #
4142: ermns: .long b$scl # string / -- /
4143: .long 4
4144: .ascii " -- "
4145: .align 2
4146: #
4147: # STRING CONSTANT FOR PAGE NUMBERING
4148: #
4149: lstms: .long b$scl # page
4150: .long 5
4151: .ascii "PAGE "
4152: .align 2
4153: #
4154: # LISTING HEADER MESSAGE
4155: #
4156: headr: .long b$scl
4157: .long 25
4158: .ascii "MACRO SPITBOL VERSION 3.5"
4159: .align 2
4160: #
4161: headv: .long b$scl # for exit() version no. check
4162: .long 3
4163: .ascii "3.5"
4164: .align 2
4165: #
4166: # INTEGER CONSTANTS FOR GENERAL USE
4167: # ICBLD OPTIMISATION USES THE FIRST THREE.
4168: #
4169: int$r: .long b$icl
4170: intv0: .long 0 # 0
4171: inton: .long b$icl
4172: intv1: .long 1 # 1
4173: inttw: .long b$icl
4174: intv2: .long 2 # 2
4175: intvt: .long 10 # 10
4176: intvh: .long 100 # 100
4177: intth: .long 1000 # 1000
4178: #
4179: # TABLE USED IN ICBLD OPTIMISATION
4180: #
4181: intab: .long int$r # pointer to 0
4182: .long inton # pointer to 1
4183: .long inttw # pointer to 2
4184: #page
4185: #
4186: # SPECIAL PATTERN NODES. THE FOLLOWING PATTERN NODES
4187: # CONSIST SIMPLY OF A PCODE POINTER, SEE MATCH ROUTINES
4188: # (P$XXX) FOR FULL DETAILS OF THEIR USE AND FORMAT).
4189: #
4190: ndabb: .long p$abb # arbno
4191: ndabd: .long p$abd # arbno
4192: ndarc: .long p$arc # arb
4193: ndexb: .long p$exb # expression
4194: ndfnb: .long p$fnb # fence()
4195: ndfnd: .long p$fnd # fence()
4196: ndexc: .long p$exc # expression
4197: ndimb: .long p$imb # immediate assignment
4198: ndimd: .long p$imd # immediate assignment
4199: ndnth: .long p$nth # pattern end (null pattern)
4200: ndpab: .long p$pab # pattern assignment
4201: ndpad: .long p$pad # pattern assignment
4202: nduna: .long p$una # anchor point movement
4203: #
4204: # KEYWORD CONSTANT PATTERN NODES. THE FOLLOWING NODES ARE
4205: # USED AS THE VALUES OF PATTERN KEYWORDS AND THE INITIAL
4206: # VALUES OF THE CORRESPONDING NATURAL VARIABLES. ALL
4207: # NODES ARE IN P0BLK FORMAT AND THE ORDER IS TIED TO THE
4208: # DEFINITIONS OF CORRESPONDING K$XXX SYMBOLS.
4209: #
4210: ndabo: .long p$abo # abort
4211: .long ndnth
4212: ndarb: .long p$arb # arb
4213: .long ndnth
4214: ndbal: .long p$bal # bal
4215: .long ndnth
4216: ndfal: .long p$fal # fail
4217: .long ndnth
4218: ndfen: .long p$fen # fence
4219: .long ndnth
4220: ndrem: .long p$rem # rem
4221: .long ndnth
4222: ndsuc: .long p$suc # succeed
4223: .long ndnth
4224: #
4225: # NULL STRING. ALL NULL VALUES POINT TO THIS STRING. THE
4226: # SVCHS FIELD CONTAINS A BLANK TO PROVIDE FOR EASY DEFAULT
4227: # PROCESSING IN TRACE, STOPTR, LPAD AND RPAD.
4228: # NULLW CONTAINS 10 BLANKS WHICH ENSURES AN ALL BLANK WORD
4229: # BUT FOR VERY EXCEPTIONAL MACHINES.
4230: #
4231: nulls: .long b$scl # null string value
4232: .long 0 # sclen = 0
4233: nullw: .ascii " "
4234: .align 2
4235: #page
4236: #
4237: # OPERATOR DOPE VECTORS (SEE DVBLK FORMAT)
4238: #
4239: opdvc: .long o$cnc # concatenation
4240: .long c$cnc
4241: .long llcnc
4242: .long rrcnc
4243: #
4244: # OPDVS IS USED WHEN SCANNING BELOW THE TOP LEVEL TO
4245: # INSURE THAT THE CONCATENATION WILL NOT BE LATER
4246: # MISTAKEN FOR PATTERN MATCHING
4247: #
4248: opdvp: .long o$cnc # concatenation - not pattern match
4249: .long c$cnp
4250: .long llcnc
4251: .long rrcnc
4252: #
4253: # NOTE THAT THE ORDER OF THE REMAINING ENTRIES IS TIED TO
4254: # THE ORDER OF THE CODING IN THE SCANE PROCEDURE.
4255: #
4256: opdvs: .long o$ass # assignment
4257: .long c$ass
4258: .long llass
4259: .long rrass
4260: #
4261: .long 6 # unary equal
4262: .long c$uuo
4263: .long lluno
4264: #
4265: .long o$pmv # pattern match
4266: .long c$pmt
4267: .long llpmt
4268: .long rrpmt
4269: #
4270: .long o$int # interrogation
4271: .long c$uvl
4272: .long lluno
4273: #
4274: .long 1 # binary ampersand
4275: .long c$ubo
4276: .long llamp
4277: .long rramp
4278: #
4279: .long o$kwv # keyword reference
4280: .long c$key
4281: .long lluno
4282: #
4283: .long o$alt # alternation
4284: .long c$alt
4285: .long llalt
4286: .long rralt
4287: #page
4288: #
4289: # OPERATOR DOPE VECTORS (CONTINUED)
4290: #
4291: .long 5 # unary vertical bar
4292: .long c$uuo
4293: .long lluno
4294: #
4295: .long 0 # binary at
4296: .long c$ubo
4297: .long llats
4298: .long rrats
4299: #
4300: .long o$cas # cursor assignment
4301: .long c$unm
4302: .long lluno
4303: #
4304: .long 2 # binary number sign
4305: .long c$ubo
4306: .long llnum
4307: .long rrnum
4308: #
4309: .long 7 # unary number sign
4310: .long c$uuo
4311: .long lluno
4312: #
4313: .long o$dvd # division
4314: .long c$bvl
4315: .long lldvd
4316: .long rrdvd
4317: #
4318: .long 9 # unary slash
4319: .long c$uuo
4320: .long lluno
4321: #
4322: .long o$mlt # multiplication
4323: .long c$bvl
4324: .long llmlt
4325: .long rrmlt
4326: #page
4327: #
4328: # OPERATOR DOPE VECTORS (CONTINUED)
4329: #
4330: .long 0 # deferred expression
4331: .long c$def
4332: .long lluno
4333: #
4334: .long 3 # binary percent
4335: .long c$ubo
4336: .long llpct
4337: .long rrpct
4338: #
4339: .long 8 # unary percent
4340: .long c$uuo
4341: .long lluno
4342: #
4343: .long o$exp # exponentiation
4344: .long c$bvl
4345: .long llexp
4346: .long rrexp
4347: #
4348: .long 10 # unary exclamation
4349: .long c$uuo
4350: .long lluno
4351: #
4352: .long o$ima # immediate assignment
4353: .long c$bvn
4354: .long lldld
4355: .long rrdld
4356: #
4357: .long o$inv # indirection
4358: .long c$ind
4359: .long lluno
4360: #
4361: .long 4 # binary not
4362: .long c$ubo
4363: .long llnot
4364: .long rrnot
4365: #
4366: .long 0 # negation
4367: .long c$neg
4368: .long lluno
4369: #page
4370: #
4371: # OPERATOR DOPE VECTORS (CONTINUED)
4372: #
4373: .long o$sub # subtraction
4374: .long c$bvl
4375: .long llplm
4376: .long rrplm
4377: #
4378: .long o$com # complementation
4379: .long c$uvl
4380: .long lluno
4381: #
4382: .long o$add # addition
4383: .long c$bvl
4384: .long llplm
4385: .long rrplm
4386: #
4387: .long o$aff # affirmation
4388: .long c$uvl
4389: .long lluno
4390: #
4391: .long o$pas # pattern assignment
4392: .long c$bvn
4393: .long lldld
4394: .long rrdld
4395: #
4396: .long o$nam # name reference
4397: .long c$unm
4398: .long lluno
4399: #
4400: # SPECIAL DVS FOR GOTO OPERATORS (SEE PROCEDURE SCNGF)
4401: #
4402: opdvd: .long o$god # direct goto
4403: .long c$uvl
4404: .long lluno
4405: #
4406: opdvn: .long o$goc # complex normal goto
4407: .long c$unm
4408: .long lluno
4409: #page
4410: #
4411: # OPERATOR ENTRY ADDRESS POINTERS, USED IN CODE
4412: #
4413: oamn$: .long o$amn # array ref (multi-subs by value)
4414: oamv$: .long o$amv # array ref (multi-subs by value)
4415: oaon$: .long o$aon # array ref (one sub by name)
4416: oaov$: .long o$aov # array ref (one sub by value)
4417: ocer$: .long o$cer # compilation error
4418: ofex$: .long o$fex # failure in expression evaluation
4419: ofif$: .long o$fif # failure during goto evaluation
4420: ofnc$: .long o$fnc # function call (more than one arg)
4421: ofne$: .long o$fne # function name error
4422: ofns$: .long o$fns # function call (single argument)
4423: ogof$: .long o$gof # set goto failure trap
4424: oinn$: .long o$inn # indirection by name
4425: okwn$: .long o$kwn # keyword reference by name
4426: olex$: .long o$lex # load expression by name
4427: olpt$: .long o$lpt # load pattern
4428: olvn$: .long o$lvn # load variable name
4429: onta$: .long o$nta # negation, first entry
4430: ontb$: .long o$ntb # negation, second entry
4431: ontc$: .long o$ntc # negation, third entry
4432: opmn$: .long o$pmn # pattern match by name
4433: opms$: .long o$pms # pattern match (statement)
4434: opop$: .long o$pop # pop top stack item
4435: ornm$: .long o$rnm # return name from expression
4436: orpl$: .long o$rpl # pattern replacement
4437: orvl$: .long o$rvl # return value from expression
4438: osla$: .long o$sla # selection, first entry
4439: oslb$: .long o$slb # selection, second entry
4440: oslc$: .long o$slc # selection, third entry
4441: osld$: .long o$sld # selection, fourth entry
4442: ostp$: .long o$stp # stop execution
4443: ounf$: .long o$unf # unexpected failure
4444: #page
4445: #
4446: # TABLE OF NAMES OF UNDEFINED BINARY OPERATORS FOR OPSYN
4447: #
4448: opsnb: .long ch$at # at
4449: .long ch$am # ampersand
4450: .long ch$nm # number
4451: .long ch$pc # percent
4452: .long ch$nt # not
4453: #
4454: # TABLE OF NAMES OF UNDEFINED UNARY OPERATORS FOR OPSYN
4455: #
4456: opnsu: .long ch$br # vertical bar
4457: .long ch$eq # equal
4458: .long ch$nm # number
4459: .long ch$pc # percent
4460: .long ch$sl # slash
4461: .long ch$ex # exclamation
4462: #
4463: # ADDRESS CONST CONTAINING PROFILE TABLE ENTRY SIZE
4464: #
4465: pfi2a: .long pf$i2
4466: #
4467: # PROFILER MESSAGE STRINGS
4468: #
4469: pfms1: .long b$scl
4470: .long 15
4471: .ascii "PROGRAM PROFILE"
4472: .align 2
4473: pfms2: .long b$scl
4474: .long 42
4475: .ascii "STMT NUMBER OF -- EXECUTION TIME --"
4476: .align 2
4477: pfms3: .long b$scl
4478: .long 47
4479: .ascii "NUMBER EXECUTIONS TOTAL(MSEC) PER EXCN(MCSEC)"
4480: .align 2
4481: #
4482: #
4483: # REAL CONSTANTS FOR GENERAL USE. NOTE THAT THE CONSTANTS
4484: # STARTING AT REAV1 FORM A POWERS OF TEN TABLE (GTSTG)
4485: #
4486: reav0: .float 0f0.0 # 0.0
4487: reap1: .float 0f0.1 # 0.1
4488: reap5: .float 0f0.5 # 0.5
4489: reav1: .float 0f1.0 # 10**0
4490: reavt: .float 0f1.0e+1 # 10**1
4491: .float 0f1.0e+2 # 10**2
4492: .float 0f1.0e+3 # 10**3
4493: .float 0f1.0e+4 # 10**4
4494: .float 0f1.0e+5 # 10**5
4495: .float 0f1.0e+6 # 10**6
4496: .float 0f1.0e+7 # 10**7
4497: .float 0f1.0e+8 # 10**8
4498: .float 0f1.0e+9 # 10**9
4499: reatt: .float 0f1.0e+10 # 10**10
4500: #page
4501: #
4502: # STRING CONSTANTS (SCBLK FORMAT) FOR DTYPE PROCEDURE
4503: #
4504: scarr: .long b$scl # array
4505: .long 5
4506: .ascii "ARRAY"
4507: .align 2
4508: #
4509: scbuf: .long b$scl # buffer
4510: .long 6
4511: .ascii "BUFFER"
4512: .align 2
4513: #
4514: sccod: .long b$scl # code
4515: .long 4
4516: .ascii "CODE"
4517: .align 2
4518: #
4519: scexp: .long b$scl # expression
4520: .long 10
4521: .ascii "EXPRESSION"
4522: .align 2
4523: #
4524: scext: .long b$scl # external
4525: .long 8
4526: .ascii "EXTERNAL"
4527: .align 2
4528: #
4529: scint: .long b$scl # integer
4530: .long 7
4531: .ascii "INTEGER"
4532: .align 2
4533: #
4534: scnam: .long b$scl # name
4535: .long 4
4536: .ascii "NAME"
4537: .align 2
4538: #
4539: scnum: .long b$scl # numeric
4540: .long 7
4541: .ascii "NUMERIC"
4542: .align 2
4543: #
4544: scpat: .long b$scl # pattern
4545: .long 7
4546: .ascii "PATTERN"
4547: .align 2
4548: #
4549: screa: .long b$scl # real
4550: .long 4
4551: .ascii "REAL"
4552: .align 2
4553: #
4554: scstr: .long b$scl # string
4555: .long 6
4556: .ascii "STRING"
4557: .align 2
4558: #
4559: sctab: .long b$scl # table
4560: .long 5
4561: .ascii "TABLE"
4562: .align 2
4563: #page
4564: #
4565: # STRING CONSTANTS (SCBLK FORMAT) FOR KVRTN (SEE RETRN)
4566: #
4567: scfrt: .long b$scl # freturn
4568: .long 7
4569: .ascii "FRETURN"
4570: .align 2
4571: #
4572: scnrt: .long b$scl # nreturn
4573: .long 7
4574: .ascii "NRETURN"
4575: .align 2
4576: #
4577: scrtn: .long b$scl # return
4578: .long 6
4579: .ascii "RETURN"
4580: .align 2
4581: #
4582: # DATATYPE NAME TABLE FOR DTYPE PROCEDURE. THE ORDER OF
4583: # THESE ENTRIES IS TIED TO THE B$XXX DEFINITIONS FOR BLOCKS
4584: #
4585: scnmt: .long scarr # arblk array
4586: .long scbuf # bfblk buffer
4587: .long sccod # cdblk code
4588: .long scexp # exblk expression
4589: .long scint # icblk integer
4590: .long scnam # nmblk name
4591: .long scpat # p0blk pattern
4592: .long scpat # p1blk pattern
4593: .long scpat # p2blk pattern
4594: .long screa # rcblk real
4595: .long scstr # scblk string
4596: .long scexp # seblk expression
4597: .long sctab # tbblk table
4598: .long scarr # vcblk array
4599: .long scext # xnblk external
4600: .long scext # xrblk external
4601: #
4602: # STRING CONSTANT FOR REAL ZERO
4603: #
4604: scre0: .long b$scl
4605: .long 2
4606: .ascii "0."
4607: .align 2
4608: #page
4609: #
4610: # USED TO RE-INITIALISE KVSTL
4611: #
4612: stlim: .long 50000 # default statement limit
4613: #
4614: # DUMMY FUNCTION BLOCK USED FOR UNDEFINED FUNCTIONS
4615: #
4616: stndf: .long o$fun # ptr to undefined function err call
4617: .long 0 # dummy fargs count for call circuit
4618: #
4619: # DUMMY CODE BLOCK USED FOR UNDEFINED LABELS
4620: #
4621: stndl: .long l$und # code ptr points to undefined lbl
4622: #
4623: # DUMMY OPERATOR BLOCK USED FOR UNDEFINED OPERATORS
4624: #
4625: stndo: .long o$oun # ptr to undefined operator err call
4626: .long 0 # dummy fargs count for call circuit
4627: #
4628: # STANDARD VARIABLE BLOCK. THIS BLOCK IS USED TO INITIALIZE
4629: # THE FIRST SEVEN FIELDS OF A NEWLY CONSTRUCTED VRBLK.
4630: # ITS FORMAT IS TIED TO THE VRBLK DEFINITIONS (SEE GTNVR).
4631: #
4632: stnvr: .long b$vrl # vrget
4633: .long b$vrs # vrsto
4634: .long nulls # vrval
4635: .long b$vrg # vrtra
4636: .long stndl # vrlbl
4637: .long stndf # vrfnc
4638: .long 0 # vrnxt
4639: #page
4640: #
4641: # MESSAGES USED IN END OF RUN PROCESSING (STOPR)
4642: #
4643: stpm1: .long b$scl # in statement
4644: .long 12
4645: .ascii "IN STATEMENT"
4646: .align 2
4647: #
4648: stpm2: .long b$scl
4649: .long 14
4650: .ascii "STMTS EXECUTED"
4651: .align 2
4652: #
4653: stpm3: .long b$scl
4654: .long 13
4655: .ascii "RUN TIME-MSEC"
4656: .align 2
4657: #
4658: stpm4: .long b$scl
4659: .long 12
4660: .ascii "MCSEC / STMT"
4661: .align 2
4662: #
4663: stpm5: .long b$scl
4664: .long 13
4665: .ascii "REGENERATIONS"
4666: .align 2
4667: #
4668: # CHARS FOR /TU/ ENDING CODE
4669: #
4670: strtu: .ascii "TU"
4671: .align 2
4672: #
4673: # TABLE USED BY CONVERT FUNCTION TO CHECK DATATYPE NAME
4674: # THE ENTRIES ARE ORDERED TO CORRESPOND TO BRANCH TABLE
4675: # IN S$CNV
4676: #
4677: svctb: .long scstr # string
4678: .long scint # integer
4679: .long scnam # name
4680: .long scpat # pattern
4681: .long scarr # array
4682: .long sctab # table
4683: .long scexp # expression
4684: .long sccod # code
4685: .long scnum # numeric
4686: .long screa # real
4687: .long scbuf # buffer
4688: .long 0 # zero marks end of list
4689: #page
4690: #
4691: # MESSAGES (SCBLK FORMAT) USED BY TRACE PROCEDURES
4692: #
4693: #
4694: tmasb: .long b$scl # asterisks for trace statement no
4695: .long 13
4696: .ascii "************ "
4697: .align 2
4698: #
4699: tmbeb: .long b$scl # blank-equal-blank
4700: .long 3
4701: .ascii " = "
4702: .align 2
4703: #
4704: # DUMMY TRBLK FOR EXPRESSION VARIABLE
4705: #
4706: trbev: .long b$trt # dummy trblk
4707: #
4708: # DUMMY TRBLK FOR KEYWORD VARIABLE
4709: #
4710: trbkv: .long b$trt # dummy trblk
4711: #
4712: # DUMMY CODE BLOCK TO RETURN CONTROL TO TRXEQ PROCEDURE
4713: #
4714: trxdr: .long o$txr # block points to return routine
4715: trxdc: .long trxdr # pointer to block
4716: #page
4717: #
4718: # STANDARD VARIABLE BLOCKS
4719: #
4720: # SEE SVBLK FORMAT FOR FULL DETAILS OF THE FORMAT. THE
4721: # VRBLKS ARE ORDERED BY LENGTH AND WITHIN EACH LENGTH THE
4722: # ORDER IS ALPHABETICAL BY NAME OF THE VARIABLE.
4723: #
4724: v$eqf: .long svfpr # eq
4725: .long 2
4726: .ascii "EQ"
4727: .align 2
4728: .long s$eqf
4729: .long 2
4730: #
4731: v$gef: .long svfpr # ge
4732: .long 2
4733: .ascii "GE"
4734: .align 2
4735: .long s$gef
4736: .long 2
4737: #
4738: v$gtf: .long svfpr # gt
4739: .long 2
4740: .ascii "GT"
4741: .align 2
4742: .long s$gtf
4743: .long 2
4744: #
4745: v$lef: .long svfpr # le
4746: .long 2
4747: .ascii "LE"
4748: .align 2
4749: .long s$lef
4750: .long 2
4751: #
4752: v$ltf: .long svfpr # lt
4753: .long 2
4754: .ascii "LT"
4755: .align 2
4756: .long s$ltf
4757: .long 2
4758: #
4759: v$nef: .long svfpr # ne
4760: .long 2
4761: .ascii "NE"
4762: .align 2
4763: .long s$nef
4764: .long 2
4765: #
4766: v$any: .long svfnp # any
4767: .long 3
4768: .ascii "ANY"
4769: .align 2
4770: .long s$any
4771: .long 1
4772: #
4773: v$arb: .long svkvc # arb
4774: .long 3
4775: .ascii "ARB"
4776: .align 2
4777: .long k$arb
4778: .long ndarb
4779: #page
4780: #
4781: # STANDARD VARIABLE BLOCKS (CONTINUED)
4782: #
4783: v$arg: .long svfnn # arg
4784: .long 3
4785: .ascii "ARG"
4786: .align 2
4787: .long s$arg
4788: .long 2
4789: #
4790: v$bal: .long svkvc # bal
4791: .long 3
4792: .ascii "BAL"
4793: .align 2
4794: .long k$bal
4795: .long ndbal
4796: #
4797: v$end: .long svlbl # end
4798: .long 3
4799: .ascii "END"
4800: .align 2
4801: .long l$end
4802: #
4803: v$len: .long svfnp # len
4804: .long 3
4805: .ascii "LEN"
4806: .align 2
4807: .long s$len
4808: .long 1
4809: #
4810: v$leq: .long svfpr # leq
4811: .long 3
4812: .ascii "LEQ"
4813: .align 2
4814: .long s$leq
4815: .long 2
4816: #
4817: v$lge: .long svfpr # lge
4818: .long 3
4819: .ascii "LGE"
4820: .align 2
4821: .long s$lge
4822: .long 2
4823: #
4824: v$lgt: .long svfpr # lgt
4825: .long 3
4826: .ascii "LGT"
4827: .align 2
4828: .long s$lgt
4829: .long 2
4830: #
4831: v$lle: .long svfpr # lle
4832: .long 3
4833: .ascii "LLE"
4834: .align 2
4835: .long s$lle
4836: .long 2
4837: #page
4838: #
4839: # STANDARD VARIABLE BLOCKS (CONTINUED)
4840: #
4841: v$llt: .long svfpr # llt
4842: .long 3
4843: .ascii "LLT"
4844: .align 2
4845: .long s$llt
4846: .long 2
4847: #
4848: v$lne: .long svfpr # lne
4849: .long 3
4850: .ascii "LNE"
4851: .align 2
4852: .long s$lne
4853: .long 2
4854: #
4855: v$pos: .long svfnp # pos
4856: .long 3
4857: .ascii "POS"
4858: .align 2
4859: .long s$pos
4860: .long 1
4861: #
4862: v$rem: .long svkvc # rem
4863: .long 3
4864: .ascii "REM"
4865: .align 2
4866: .long k$rem
4867: .long ndrem
4868: #
4869: v$set: .long svfnn # set
4870: .long 3
4871: .ascii "SET"
4872: .align 2
4873: .long s$set
4874: .long 3
4875: #
4876: v$tab: .long svfnp # tab
4877: .long 3
4878: .ascii "TAB"
4879: .align 2
4880: .long s$tab
4881: .long 1
4882: #
4883: v$cas: .long svknm # case
4884: .long 4
4885: .ascii "CASE"
4886: .align 2
4887: .long k$cas
4888: #
4889: v$chr: .long svfnp # char
4890: .long 4
4891: .ascii "CHAR"
4892: .align 2
4893: .long s$chr
4894: .long 1
4895: #
4896: v$cod: .long svfnk # code
4897: .long 4
4898: .ascii "CODE"
4899: .align 2
4900: .long k$cod
4901: .long s$cod
4902: .long 1
4903: #
4904: v$cop: .long svfnn # copy
4905: .long 4
4906: .ascii "COPY"
4907: .align 2
4908: .long s$cop
4909: .long 1
4910: #page
4911: #
4912: # STANDARD VARIABLE BLOCKS (CONTINUED)
4913: #
4914: v$dat: .long svfnn # data
4915: .long 4
4916: .ascii "DATA"
4917: .align 2
4918: .long s$dat
4919: .long 1
4920: #
4921: v$dte: .long svfnn # date
4922: .long 4
4923: .ascii "DATE"
4924: .align 2
4925: .long s$dte
4926: .long 0
4927: #
4928: v$dmp: .long svfnk # dump
4929: .long 4
4930: .ascii "DUMP"
4931: .align 2
4932: .long k$dmp
4933: .long s$dmp
4934: .long 1
4935: #
4936: v$dup: .long svfnn # dupl
4937: .long 4
4938: .ascii "DUPL"
4939: .align 2
4940: .long s$dup
4941: .long 2
4942: #
4943: v$evl: .long svfnn # eval
4944: .long 4
4945: .ascii "EVAL"
4946: .align 2
4947: .long s$evl
4948: .long 1
4949: #
4950: v$ext: .long svfnn # exit
4951: .long 4
4952: .ascii "EXIT"
4953: .align 2
4954: .long s$ext
4955: .long 1
4956: #
4957: v$fal: .long svkvc # fail
4958: .long 4
4959: .ascii "FAIL"
4960: .align 2
4961: .long k$fal
4962: .long ndfal
4963: #
4964: v$hst: .long svfnn # host
4965: .long 4
4966: .ascii "HOST"
4967: .align 2
4968: .long s$hst
4969: .long 3
4970: #page
4971: #
4972: # STANDARD VARIABLE BLOCKS (CONTINUED)
4973: #
4974: v$itm: .long svfnf # item
4975: .long 4
4976: .ascii "ITEM"
4977: .align 2
4978: .long s$itm
4979: .long 999
4980: #
4981: v$lod: .long svfnn # load
4982: .long 4
4983: .ascii "LOAD"
4984: .align 2
4985: .long s$lod
4986: .long 2
4987: #
4988: v$lpd: .long svfnp # lpad
4989: .long 4
4990: .ascii "LPAD"
4991: .align 2
4992: .long s$lpd
4993: .long 3
4994: #
4995: v$rpd: .long svfnp # rpad
4996: .long 4
4997: .ascii "RPAD"
4998: .align 2
4999: .long s$rpd
5000: .long 3
5001: #
5002: v$rps: .long svfnp # rpos
5003: .long 4
5004: .ascii "RPOS"
5005: .align 2
5006: .long s$rps
5007: .long 1
5008: #
5009: v$rtb: .long svfnp # rtab
5010: .long 4
5011: .ascii "RTAB"
5012: .align 2
5013: .long s$rtb
5014: .long 1
5015: #
5016: v$si$: .long svfnp # size
5017: .long 4
5018: .ascii "SIZE"
5019: .align 2
5020: .long s$si$
5021: .long 1
5022: #
5023: #
5024: v$srt: .long svfnn # sort
5025: .long 4
5026: .ascii "SORT"
5027: .align 2
5028: .long s$srt
5029: .long 2
5030: v$spn: .long svfnp # span
5031: .long 4
5032: .ascii "SPAN"
5033: .align 2
5034: .long s$spn
5035: .long 1
5036: #page
5037: #
5038: # STANDARD VARIABLE BLOCKS (CONTINUED)
5039: #
5040: v$stn: .long svknm # stno
5041: .long 4
5042: .ascii "STNO"
5043: .align 2
5044: .long k$stn
5045: #
5046: v$tim: .long svfnn # time
5047: .long 4
5048: .ascii "TIME"
5049: .align 2
5050: .long s$tim
5051: .long 0
5052: #
5053: v$trm: .long svfnk # trim
5054: .long 4
5055: .ascii "TRIM"
5056: .align 2
5057: .long k$trm
5058: .long s$trm
5059: .long 1
5060: #
5061: v$abe: .long svknm # abend
5062: .long 5
5063: .ascii "ABEND"
5064: .align 2
5065: .long k$abe
5066: #
5067: v$abo: .long svkvl # abort
5068: .long 5
5069: .ascii "ABORT"
5070: .align 2
5071: .long k$abo
5072: .long l$abo
5073: .long ndabo
5074: #
5075: v$app: .long svfnf # apply
5076: .long 5
5077: .ascii "APPLY"
5078: .align 2
5079: .long s$app
5080: .long 999
5081: #
5082: v$abn: .long svfnp # arbno
5083: .long 5
5084: .ascii "ARBNO"
5085: .align 2
5086: .long s$abn
5087: .long 1
5088: #
5089: v$arr: .long svfnn # array
5090: .long 5
5091: .ascii "ARRAY"
5092: .align 2
5093: .long s$arr
5094: .long 2
5095: #page
5096: #
5097: # STANDARD VARIABLE BLOCKS (CONTINUED)
5098: #
5099: v$brk: .long svfnp # break
5100: .long 5
5101: .ascii "BREAK"
5102: .align 2
5103: .long s$brk
5104: .long 1
5105: #
5106: v$clr: .long svfnn # clear
5107: .long 5
5108: .ascii "CLEAR"
5109: .align 2
5110: .long s$clr
5111: .long 1
5112: #
5113: v$ejc: .long svfnn # eject
5114: .long 5
5115: .ascii "EJECT"
5116: .align 2
5117: .long s$ejc
5118: .long 1
5119: #
5120: v$fen: .long svfpk # fence
5121: .long 5
5122: .ascii "FENCE"
5123: .align 2
5124: .long k$fen
5125: .long s$fnc
5126: .long 1
5127: .long ndfen
5128: #
5129: v$fld: .long svfnn # field
5130: .long 5
5131: .ascii "FIELD"
5132: .align 2
5133: .long s$fld
5134: .long 2
5135: #
5136: v$idn: .long svfpr # ident
5137: .long 5
5138: .ascii "IDENT"
5139: .align 2
5140: .long s$idn
5141: .long 2
5142: #
5143: v$inp: .long svfnk # input
5144: .long 5
5145: .ascii "INPUT"
5146: .align 2
5147: .long k$inp
5148: .long s$inp
5149: .long 3
5150: #
5151: v$loc: .long svfnn # local
5152: .long 5
5153: .ascii "LOCAL"
5154: .align 2
5155: .long s$loc
5156: .long 2
5157: #page
5158: #
5159: # STANDARD VARIABLE BLOCKS (CONTINUED)
5160: #
5161: v$ops: .long svfnn # opsyn
5162: .long 5
5163: .ascii "OPSYN"
5164: .align 2
5165: .long s$ops
5166: .long 3
5167: #
5168: v$rmd: .long svfnp # remdr
5169: .long 5
5170: .ascii "REMDR"
5171: .align 2
5172: .long s$rmd
5173: .long 2
5174: #
5175: v$rsr: .long svfnn # rsort
5176: .long 5
5177: .ascii "RSORT"
5178: .align 2
5179: .long s$rsr
5180: .long 2
5181: #
5182: v$tbl: .long svfnn # table
5183: .long 5
5184: .ascii "TABLE"
5185: .align 2
5186: .long s$tbl
5187: .long 3
5188: #
5189: v$tra: .long svfnk # trace
5190: .long 5
5191: .ascii "TRACE"
5192: .align 2
5193: .long k$tra
5194: .long s$tra
5195: .long 4
5196: #
5197: v$anc: .long svknm # anchor
5198: .long 6
5199: .ascii "ANCHOR"
5200: .align 2
5201: .long k$anc
5202: #
5203: v$apn: .long svfnn
5204: .long 6
5205: .ascii "APPEND"
5206: .align 2
5207: .long s$apn
5208: .long 2
5209: #
5210: v$bkx: .long svfnp # breakx
5211: .long 6
5212: .ascii "BREAKX"
5213: .align 2
5214: .long s$bkx
5215: .long 1
5216: #
5217: v$buf: .long svfnn # buffer
5218: .long 6
5219: .ascii "BUFFER"
5220: .align 2
5221: .long s$buf
5222: .long 2
5223: #
5224: v$def: .long svfnn # define
5225: .long 6
5226: .ascii "DEFINE"
5227: .align 2
5228: .long s$def
5229: .long 2
5230: #
5231: v$det: .long svfnn # detach
5232: .long 6
5233: .ascii "DETACH"
5234: .align 2
5235: .long s$det
5236: .long 1
5237: #page
5238: #
5239: # STANDARD VARIABLE BLOCKS (CONTINUED)
5240: #
5241: v$dif: .long svfpr # differ
5242: .long 6
5243: .ascii "DIFFER"
5244: .align 2
5245: .long s$dif
5246: .long 2
5247: #
5248: v$ftr: .long svknm # ftrace
5249: .long 6
5250: .ascii "FTRACE"
5251: .align 2
5252: .long k$ftr
5253: #
5254: v$ins: .long svfnn # insert
5255: .long 6
5256: .ascii "INSERT"
5257: .align 2
5258: .long s$ins
5259: .long 4
5260: #
5261: v$lst: .long svknm # lastno
5262: .long 6
5263: .ascii "LASTNO"
5264: .align 2
5265: .long k$lst
5266: #
5267: v$nay: .long svfnp # notany
5268: .long 6
5269: .ascii "NOTANY"
5270: .align 2
5271: .long s$nay
5272: .long 1
5273: #
5274: v$oup: .long svfnk # output
5275: .long 6
5276: .ascii "OUTPUT"
5277: .align 2
5278: .long k$oup
5279: .long s$oup
5280: .long 3
5281: #
5282: v$ret: .long svlbl # return
5283: .long 6
5284: .ascii "RETURN"
5285: .align 2
5286: .long l$rtn
5287: #
5288: v$rew: .long svfnn # rewind
5289: .long 6
5290: .ascii "REWIND"
5291: .align 2
5292: .long s$rew
5293: .long 1
5294: #
5295: v$stt: .long svfnn # stoptr
5296: .long 6
5297: .ascii "STOPTR"
5298: .align 2
5299: .long s$stt
5300: .long 2
5301: #page
5302: #
5303: # STANDARD VARIABLE BLOCKS (CONTINUED)
5304: #
5305: v$sub: .long svfnn # substr
5306: .long 6
5307: .ascii "SUBSTR"
5308: .align 2
5309: .long s$sub
5310: .long 3
5311: #
5312: v$unl: .long svfnn # unload
5313: .long 6
5314: .ascii "UNLOAD"
5315: .align 2
5316: .long s$unl
5317: .long 1
5318: #
5319: v$col: .long svfnn # collect
5320: .long 7
5321: .ascii "COLLECT"
5322: .align 2
5323: .long s$col
5324: .long 1
5325: #
5326: v$cnv: .long svfnn # convert
5327: .long 7
5328: .ascii "CONVERT"
5329: .align 2
5330: .long s$cnv
5331: .long 2
5332: #
5333: v$enf: .long svfnn # endfile
5334: .long 7
5335: .ascii "ENDFILE"
5336: .align 2
5337: .long s$enf
5338: .long 1
5339: #
5340: v$etx: .long svknm # errtext
5341: .long 7
5342: .ascii "ERRTEXT"
5343: .align 2
5344: .long k$etx
5345: #
5346: v$ert: .long svknm # errtype
5347: .long 7
5348: .ascii "ERRTYPE"
5349: .align 2
5350: .long k$ert
5351: #
5352: v$frt: .long svlbl # freturn
5353: .long 7
5354: .ascii "FRETURN"
5355: .align 2
5356: .long l$frt
5357: #
5358: v$int: .long svfpr # integer
5359: .long 7
5360: .ascii "INTEGER"
5361: .align 2
5362: .long s$int
5363: .long 1
5364: #
5365: v$nrt: .long svlbl # nreturn
5366: .long 7
5367: .ascii "NRETURN"
5368: .align 2
5369: .long l$nrt
5370: #page
5371: #
5372: # STANDARD VARIABLE BLOCKS (CONTINUED)
5373: #
5374: #
5375: v$pfl: .long svknm # profile
5376: .long 7
5377: .ascii "PROFILE"
5378: .align 2
5379: .long k$pfl
5380: #
5381: v$rpl: .long svfnp # replace
5382: .long 7
5383: .ascii "REPLACE"
5384: .align 2
5385: .long s$rpl
5386: .long 3
5387: #
5388: v$rvs: .long svfnp # reverse
5389: .long 7
5390: .ascii "REVERSE"
5391: .align 2
5392: .long s$rvs
5393: .long 1
5394: #
5395: v$rtn: .long svknm # rtntype
5396: .long 7
5397: .ascii "RTNTYPE"
5398: .align 2
5399: .long k$rtn
5400: #
5401: v$stx: .long svfnn # setexit
5402: .long 7
5403: .ascii "SETEXIT"
5404: .align 2
5405: .long s$stx
5406: .long 1
5407: #
5408: v$stc: .long svknm # stcount
5409: .long 7
5410: .ascii "STCOUNT"
5411: .align 2
5412: .long k$stc
5413: #
5414: v$stl: .long svknm # stlimit
5415: .long 7
5416: .ascii "STLIMIT"
5417: .align 2
5418: .long k$stl
5419: #
5420: v$suc: .long svkvc # succeed
5421: .long 7
5422: .ascii "SUCCEED"
5423: .align 2
5424: .long k$suc
5425: .long ndsuc
5426: #
5427: v$alp: .long svkwc # alphabet
5428: .long 8
5429: .ascii "ALPHABET"
5430: .align 2
5431: .long k$alp
5432: #
5433: v$cnt: .long svlbl # continue
5434: .long 8
5435: .ascii "CONTINUE"
5436: .align 2
5437: .long l$cnt
5438: #page
5439: #
5440: # STANDARD VARIABLE BLOCKS (CONTINUED)
5441: #
5442: v$dtp: .long svfnp # datatype
5443: .long 8
5444: .ascii "DATATYPE"
5445: .align 2
5446: .long s$dtp
5447: .long 1
5448: #
5449: v$erl: .long svknm # errlimit
5450: .long 8
5451: .ascii "ERRLIMIT"
5452: .align 2
5453: .long k$erl
5454: #
5455: v$fnc: .long svknm # fnclevel
5456: .long 8
5457: .ascii "FNCLEVEL"
5458: .align 2
5459: .long k$fnc
5460: #
5461: v$mxl: .long svknm # maxlngth
5462: .long 8
5463: .ascii "MAXLNGTH"
5464: .align 2
5465: .long k$mxl
5466: #
5467: v$ter: .long 0 # terminal
5468: .long 8
5469: .ascii "TERMINAL"
5470: .align 2
5471: .long 0
5472: #
5473: v$pro: .long svfnn # prototype
5474: .long 9
5475: .ascii "PROTOTYPE"
5476: .align 2
5477: .long s$pro
5478: .long 1
5479: #
5480: .long 0 # dummy entry to end list
5481: .long 10 # length gt 9 (prototype)
5482: #page
5483: #
5484: # LIST OF SVBLK POINTERS FOR KEYWORDS TO BE DUMPED. THE
5485: # LIST IS IN THE ORDER WHICH APPEARS ON THE DUMP OUTPUT.
5486: #
5487: vdmkw: .long v$anc # anchor
5488: .long v$cas # ccase
5489: .long v$cod # code
5490: .long v$dmp # dump
5491: .long v$erl # errlimit
5492: .long v$etx # errtext
5493: .long v$ert # errtype
5494: .long v$fnc # fnclevel
5495: .long v$ftr # ftrace
5496: .long v$inp # input
5497: .long v$lst # lastno
5498: .long v$mxl # maxlength
5499: .long v$oup # output
5500: .long v$pfl # profile
5501: .long v$rtn # rtntype
5502: .long v$stc # stcount
5503: .long v$stl # stlimit
5504: .long v$stn # stno
5505: .long v$tra # trace
5506: .long v$trm # trim
5507: .long 0 # end of list
5508: #
5509: # TABLE USED BY GTNVR TO SEARCH SVBLK LISTS
5510: #
5511: vsrch: .long 0 # dummy entry to get proper indexing
5512: .long v$eqf # start of 1 char variables (none)
5513: .long v$eqf # start of 2 char variables
5514: .long v$any # start of 3 char variables
5515: .long v$cas # start of 4 char variables
5516: .long v$abe # start of 5 char variables
5517: .long v$anc # start of 6 char variables
5518: .long v$col # start of 7 char variables
5519: .long v$alp # start of 8 char variables
5520: .long v$pro # start of 9 char variables
5521: #title s p i t b o l -- working storage section
5522: #
5523: # THE WORKING STORAGE SECTION CONTAINS AREAS WHICH ARE
5524: # CHANGED DURING EXECUTION OF THE PROGRAM. THE VALUE
5525: # ASSEMBLED IS THE INITIAL VALUE BEFORE EXECUTION STARTS.
5526: #
5527: # ALL THESE AREAS ARE FIXED LENGTH AREAS. VARIABLE LENGTH
5528: # DATA IS STORED IN THE STATIC OR DYNAMIC REGIONS OF THE
5529: # ALLOCATED DATA AREAS.
5530: #
5531: # THE VALUES IN THIS AREA ARE DESCRIBED EITHER AS WORK
5532: # AREAS OR AS GLOBAL VALUES. A WORK AREA IS USED IN AN
5533: # EPHEMERAL MANNER AND THE VALUE IS NOT SAVED FROM ONE
5534: # ENTRY INTO A ROUTINE TO ANOTHER. A GLOBAL VALUE IS A
5535: # LESS TEMPORARY LOCATION WHOSE VALUE IS SAVED FROM ONE
5536: # CALL TO ANOTHER.
5537: #
5538: # A GENERAL PART OF THE APPROACH IN THIS PROGRAM IS NOT
5539: # TO OVERLAP WORK AREAS BETWEEN PROCEDURES EVEN THOUGH A
5540: # SMALL AMOUNT OF SPACE COULD BE SAVED. SUCH OVERLAP IS
5541: # CONSIDERED A SOURCE OF PROGRAM ERRORS AND DECREASES THE
5542: # INFORMATION LEFT BEHIND AFTER A SYSTEM CRASH OF ANY KIND.
5543: #
5544: # THE NAMES OF THESE LOCATIONS ARE LABELS WITH FIVE LETTER
5545: # (A-Y,$) NAMES. AS FAR AS POSSIBLE THE ORDER IS KEPT
5546: # ALPHABETICAL BY THESE NAMES BUT IN SOME CASES THERE
5547: # ARE SLIGHT DEPARTURES CAUSED BY OTHER ORDER REQUIREMENTS.
5548: #
5549: # UNLESS OTHERWISE DOCUMENTED, THE ORDER OF WORK AREAS
5550: # DOES NOT AFFECT THE EXECUTION OF THE SPITBOL PROGRAM.
5551: #
5552: .data 1
5553: #sec # start of working storage section
5554: #page
5555: #
5556: # THIS AREA IS NOT CLEARED BY INITIAL CODE
5557: #
5558: cmlab: .long b$scl # string used to check label legality
5559: .long 2
5560: .ascii " "
5561: .align 2
5562: #
5563: # LABEL TO MARK START OF WORK AREA
5564: #
5565: aaaaa: .long 0
5566: #
5567: # WORK AREAS FOR ALLOC PROCEDURE
5568: #
5569: aldyn: .long 0 # amount of dynamic store
5570: alfsf: .long 0 # factor in free store pcntage check
5571: allia: .long 0 # dump ia
5572: allsv: .long 0 # save wb in alloc
5573: #
5574: # WORK AREAS FOR ALOST PROCEDURE
5575: #
5576: alsta: .long 0 # save wa in alost
5577: #
5578: # SAVE AREAS FOR ARRAY FUNCTION (S$ARR)
5579: #
5580: arcdm: .long 0 # count dimensions
5581: arnel: .long 0 # count elements
5582: arptr: .long 0 # offset ptr into arblk
5583: arsvl: .long 0 # save integer low bound
5584: #page
5585: # WORK AREAS FOR ARREF ROUTINE
5586: #
5587: arfsi: .long 0 # save current evolving subscript
5588: arfxs: .long 0 # save base stack pointer
5589: #
5590: # WORK AREAS FOR B$EFC BLOCK ROUTINE
5591: #
5592: befof: .long 0 # save offset ptr into efblk
5593: #
5594: # WORK AREAS FOR B$PFC BLOCK ROUTINE
5595: #
5596: bpfpf: .long 0 # save pfblk pointer
5597: bpfsv: .long 0 # save old function value
5598: bpfxt: .long 0 # pointer to stacked arguments
5599: #
5600: # SAVE AREAS FOR COLLECT FUNCTION (S$COL)
5601: #
5602: clsvi: .long 0 # save integer argument
5603: #
5604: # GLOBAL VALUES FOR CMPIL PROCEDURE
5605: #
5606: cmerc: .long 0 # count of initial compile errors
5607: cmpxs: .long 0 # save stack ptr in case of errors
5608: cmpsn: .long 1 # number of next statement to compile
5609: cmpss: .long 0 # save subroutine stack ptr
5610: #
5611: # WORK AREA FOR CNCRD
5612: #
5613: cnscc: .long 0 # pointer to control card string
5614: cnswc: .long 0 # word count
5615: cnr$t: .long 0 # pointer to r$ttl or r$stl
5616: cnttl: .long 0 # flag for -title, -stitl
5617: #
5618: # WORK AREAS FOR CONVERT FUNCTION (S$CNV)
5619: #
5620: cnvtp: .long 0 # save ptr into scvtb
5621: #
5622: # FLAG FOR SUPPRESSION OF COMPILATION STATISTICS.
5623: #
5624: cpsts: .long 0 # suppress comp. stats if non zero
5625: #
5626: # GLOBAL VALUES FOR CONTROL CARD SWITCHES
5627: #
5628: cswdb: .long 0 # 0/1 for -single/-double
5629: cswer: .long 0 # 0/1 for -errors/-noerrors
5630: cswex: .long 0 # 0/1 for -execute/-noexecute
5631: cswfl: .long 1 # 0/1 for -nofail/-fail
5632: cswin: .long iniln # xxx for -inxxx
5633: cswls: .long 1 # 0/1 for -nolist/-list
5634: cswno: .long 0 # 0/1 for -optimise/-noopt
5635: cswpr: .long 0 # 0/1 for -noprint/-print
5636: #
5637: # GLOBAL LOCATION USED BY PATST PROCEDURE
5638: #
5639: ctmsk: .long 0 # last bit position used in r$ctp
5640: curid: .long 0 # current id value
5641: #page
5642: #
5643: # GLOBAL VALUE FOR CDWRD PROCEDURE
5644: #
5645: cwcof: .long 0 # next word offset in current ccblk
5646: #
5647: # WORK AREAS FOR DATA FUNCTION (S$DAT)
5648: #
5649: datdv: .long 0 # save vrblk ptr for datatype name
5650: datxs: .long 0 # save initial stack pointer
5651: #
5652: # WORK AREAS FOR DEFINE FUNCTION (S$DEF)
5653: #
5654: deflb: .long 0 # save vrblk ptr for label
5655: defna: .long 0 # count function arguments
5656: defvr: .long 0 # save vrblk ptr for function name
5657: defxs: .long 0 # save initial stack pointer
5658: #
5659: # WORK AREAS FOR DUMPR PROCEDURE
5660: #
5661: dmarg: .long 0 # dump argument
5662: dmpkb: .long b$kvt # dummy kvblk for use in dumpr
5663: dmpkt: .long trbkv # kvvar trblk pointer
5664: dmpkn: .long 0 # keyword number (must follow dmpkb)
5665: dmpsa: .long 0 # preserve wa over prtvl call
5666: dmpsv: .long 0 # general scratch save
5667: dmvch: .long 0 # chain pointer for variable blocks
5668: dmpch: .long 0 # save sorted vrblk chain pointer
5669: #
5670: # GLOBAL LOCATIONS FOR DYNAMIC STORAGE POINTERS
5671: #
5672: dnamb: .long 0 # start of dynamic area
5673: dnamp: .long 0 # next available loc in dynamic area
5674: dname: .long 0 # end of available dynamic area
5675: #
5676: # WORK AREA FOR DTACH
5677: #
5678: dtcnb: .long 0 # name base
5679: dtcnm: .long 0 # name ptr
5680: #
5681: # WORK AREAS FOR DUPL FUNCTION (S$DUP)
5682: #
5683: dupsi: .long 0 # store integer string length
5684: #
5685: # WORK AREA FOR ENDFILE (S$ENF)
5686: #
5687: enfch: .long 0 # for iochn chain head
5688: #
5689: # WORK AREA FOR ERROR PROCESSING.
5690: #
5691: erich: .long 0 # copy error reports to int.chan if 1
5692: erlst: .long 0 # for listr when errors go to int.ch.
5693: errft: .long 0 # fatal error flag
5694: errsp: .long 0 # error suppression flag
5695: #page
5696: #
5697: # DUMP AREA FOR ERTEX
5698: #
5699: ertwa: .long 0 # save wa
5700: ertwb: .long 0 # save wb
5701: #
5702: # GLOBAL VALUES FOR EVALI
5703: #
5704: evlin: .long p$len # dummy pattern block pcode
5705: evlis: .long 0 # pointer to subsequent node
5706: evliv: .long 0 # value of parameter
5707: # WORK AREA FOR EXPAN
5708: #
5709: expsv: .long 0 # save op dope vector pointer
5710: #
5711: # FLAG FOR SUPPRESSION OF EXECUTION STATS
5712: #
5713: exsts: .long 0 # suppress exec stats if set
5714: #
5715: # GLOBAL VALUES FOR EXFAL AND RETURN
5716: #
5717: flprt: .long 0 # location of fail offset for return
5718: flptr: .long 0 # location of failure offset on stack
5719: #
5720: # WORK AREAS FOR GBCOL PROCEDURE
5721: #
5722: gbcfl: .long 0 # garbage collector active flag
5723: gbclm: .long 0 # pointer to last move block (pass 3)
5724: gbcnm: .long 0 # dummy first move block
5725: gbcns: .long 0 # rest of dummy block (follows gbcnm)
5726: gbsva: .long 0 # save wa
5727: gbsvb: .long 0 # save wb
5728: gbsvc: .long 0 # save wc
5729: #
5730: # GLOBAL LOCATION TO COUNT GARBAGE COLLECTIONS (GBCOL)
5731: #
5732: gbcnt: .long 0 # count of garbage collections
5733: #
5734: # WORK AREAS FOR GTNVR PROCEDURE
5735: #
5736: gnvhe: .long 0 # ptr to end of hash chain
5737: gnvnw: .long 0 # number of words in string name
5738: gnvsa: .long 0 # save wa
5739: gnvsb: .long 0 # save wb
5740: gnvsp: .long 0 # pointer into vsrch table
5741: gnvst: .long 0 # pointer to chars of string
5742: #
5743: # GLOBAL VALUE FOR GTCOD AND GTEXP
5744: #
5745: gtcef: .long 0 # save fail ptr in case of error
5746: #
5747: # WORK AREAS FOR GTINT
5748: #
5749: gtina: .long 0 # save wa
5750: gtinb: .long 0 # save wb
5751: #page
5752: #
5753: # WORK AREAS FOR GTNUM PROCEDURE
5754: #
5755: gtnnf: .long 0 # zero/nonzero for result +/-
5756: gtnsi: .long 0 # general integer save
5757: gtndf: .long 0 # 0/1 for dec point so far no/yes
5758: gtnes: .long 0 # zero/nonzero exponent +/-
5759: gtnex: .long 0 # real exponent
5760: gtnsc: .long 0 # scale (places after point)
5761: gtnsr: .float 0f0.0 # general real save
5762: gtnrd: .long 0 # flag for ok real number
5763: #
5764: # WORK AREAS FOR GTPAT PROCEDURE
5765: #
5766: gtpsb: .long 0 # save wb
5767: #
5768: # WORK AREAS FOR GTSTG PROCEDURE
5769: #
5770: gtssf: .long 0 # 0/1 for result +/-
5771: gtsvc: .long 0 # save wc
5772: gtsvb: .long 0 # save wb
5773: gtswk: .long 0 # ptr to work area for gtstg
5774: gtses: .long 0 # char + or - for exponent +/-
5775: gtsrs: .float 0f0.0 # general real save
5776: #
5777: # GLOBAL LOCATIONS (CONSTANTS) FOR GTSTG PROCEDURE
5778: #
5779: gtsrn: .float 0f0.0 # rounding factor 0.5*10**-cfp$s
5780: gtssc: .float 0f0.0 # scaling value 10**cfp$s
5781: #
5782: # WORK AREAS FOR GTVAR PROCEDURE
5783: #
5784: gtvrc: .long 0 # save wc
5785: #
5786: # FLAG FOR HEADER PRINTING
5787: #
5788: headp: .long 0 # header printed flag
5789: #
5790: # GLOBAL VALUES FOR VARIABLE HASH TABLE
5791: #
5792: hshnb: .long 0 # number of hash buckets
5793: hshtb: .long 0 # pointer to start of vrblk hash tabl
5794: hshte: .long 0 # pointer past end of vrblk hash tabl
5795: #
5796: # WORK AREA FOR INIT
5797: #
5798: iniss: .long 0 # save subroutine stack ptr
5799: initr: .long 0 # save terminal flag
5800: #
5801: # SAVE AREA FOR INSBF
5802: #
5803: insab: .long 0 # entry wa + entry wb
5804: inssa: .long 0 # save entry wa
5805: inssb: .long 0 # save entry wb
5806: inssc: .long 0 # save entry wc
5807: #
5808: # WORK AREAS FOR IOPUT
5809: #
5810: ioptt: .long 0 # type of association
5811: #page
5812: #
5813: # GLOBAL VALUES FOR KEYWORD VALUES WHICH ARE STORED AS ONE
5814: # WORD INTEGERS. THESE VALUES MUST BE ASSEMBLED IN THE
5815: # FOLLOWING ORDER (AS DICTATED BY K$XXX DEFINITION VALUES).
5816: #
5817: kvabe: .long 0 # abend
5818: kvanc: .long 0 # anchor
5819: kvcas: .long 0 # case
5820: kvcod: .long 0 # code
5821: kvdmp: .long 0 # dump
5822: kverl: .long 0 # errlimit
5823: kvert: .long 0 # errtype
5824: kvftr: .long 0 # ftrace
5825: kvinp: .long 1 # input
5826: kvmxl: .long 5000 # maxlength
5827: kvoup: .long 1 # output
5828: kvpfl: .long 0 # profile
5829: kvtra: .long 0 # trace
5830: kvtrm: .long 0 # trim
5831: kvfnc: .long 0 # fnclevel
5832: kvlst: .long 0 # lastno
5833: kvstn: .long 0 # stno
5834: #
5835: # GLOBAL VALUES FOR OTHER KEYWORDS
5836: #
5837: kvalp: .long 0 # alphabet
5838: kvrtn: .long nulls # rtntype (scblk pointer)
5839: kvstl: .long 50000 # stlimit
5840: kvstc: .long 50000 # stcount (counts down from stlimit)
5841: #
5842: # WORK AREAS FOR LOAD FUNCTION
5843: #
5844: lodfn: .long 0 # pointer to vrblk for func name
5845: lodna: .long 0 # count number of arguments
5846: #
5847: # GLOBAL VALUES FOR LISTR PROCEDURE
5848: #
5849: lstlc: .long 0 # count lines on source list page
5850: lstnp: .long 0 # max number of lines on page
5851: lstpf: .long 1 # set nonzero if current image listed
5852: lstpg: .long 0 # current source list page number
5853: lstpo: .long 0 # offset to page nnn message
5854: lstsn: .long 0 # remember last stmnum listed
5855: #
5856: # MAXIMUM SIZE OF SPITBOL OBJECTS
5857: #
5858: mxlen: .long 0 # initialised by sysmx call
5859: #
5860: # EXECUTION CONTROL VARIABLE
5861: #
5862: noxeq: .long 0 # set non-zero to inhibit execution
5863: #
5864: # PROFILER GLOBAL VALUES AND WORK LOCATIONS
5865: #
5866: pfdmp: .long 0 # set non-0 if &profile set non-0
5867: pffnc: .long 0 # set non-0 if funct just entered
5868: pfstm: .long 0 # to store starting time of stmt
5869: pfetm: .long 0 # to store ending time of stmt
5870: pfsvw: .long 0 # to save a w-reg
5871: pftbl: .long 0 # gets adrs of (imag) table base
5872: pfnte: .long 0 # nr of table entries
5873: pfste: .long 0 # gets int rep of table entry size
5874: #
5875: #page
5876: #
5877: # GLOBAL VALUES USED IN PATTERN MATCH ROUTINES
5878: #
5879: pmdfl: .long 0 # pattern assignment flag
5880: pmhbs: .long 0 # history stack base pointer
5881: pmssl: .long 0 # length of subject string in chars
5882: #
5883: # FLAGS USED FOR STANDARD FILE LISTING OPTIONS
5884: #
5885: prich: .long 0 # printer on interactive channel
5886: prstd: .long 0 # tested by prtpg
5887: prsto: .long 0 # standard listing option flag
5888: #
5889: # GLOBAL VALUE FOR PRTNM PROCEDURE
5890: #
5891: prnmv: .long 0 # vrblk ptr from last name search
5892: #
5893: # WORK AREAS FOR PRTNM PROCEDURE
5894: #
5895: prnsi: .long 0 # scratch integer loc
5896: #
5897: # WORK AREAS FOR PRTSN PROCEDURE
5898: #
5899: prsna: .long 0 # save wa
5900: #
5901: # GLOBAL VALUES FOR PRINT PROCEDURES
5902: #
5903: prbuf: .long 0 # ptr to print bfr in static
5904: precl: .long 0 # extended/compact listing flag
5905: prlen: .long 0 # length of print buffer in chars
5906: prlnw: .long 0 # length of print buffer in words
5907: profs: .long 0 # offset to next location in prbuf
5908: prtef: .long 0 # endfile flag
5909: #
5910: # WORK AREAS FOR PRTST PROCEDURE
5911: #
5912: prsva: .long 0 # save wa
5913: prsvb: .long 0 # save wb
5914: prsvc: .long 0 # save char counter
5915: #
5916: # WORK AREA FOR PRTNL
5917: #
5918: prtsa: .long 0 # save wa
5919: prtsb: .long 0 # save wb
5920: #
5921: # WORK AREA FOR PRTVL
5922: #
5923: prvsi: .long 0 # save idval
5924: #
5925: # WORK AREAS FOR PATTERN MATCH ROUTINES
5926: #
5927: psave: .long 0 # temporary save for current node ptr
5928: psavc: .long 0 # save cursor in p$spn, p$str
5929: #page
5930: #
5931: # AMOUNT OF MEMORY RESERVED FOR END OF EXECUTION
5932: #
5933: rsmem: .long 0 # reserve memory
5934: #
5935: # WORK AREAS FOR RETRN ROUTINE
5936: #
5937: rtnbp: .long 0 # to save a block pointer
5938: rtnfv: .long 0 # new function value (result)
5939: rtnsv: .long 0 # old function value (saved value)
5940: #
5941: # RELOCATABLE GLOBAL VALUES
5942: #
5943: # ALL THE POINTERS IN THIS SECTION CAN POINT TO BLOCKS IN
5944: # THE DYNAMIC STORAGE AREA AND MUST BE RELOCATED BY THE
5945: # GARBAGE COLLECTOR. THEY ARE IDENTIFIED BY R$XXX NAMES.
5946: #
5947: r$aaa: .long 0 # start of relocatable values
5948: r$arf: .long 0 # array block pointer for arref
5949: r$ccb: .long 0 # ptr to ccblk being built (cdwrd)
5950: r$cim: .long 0 # ptr to current compiler input str
5951: r$cmp: .long 0 # copy of r$cim used in cmpil
5952: r$cni: .long 0 # ptr to next compiler input string
5953: r$cnt: .long 0 # cdblk pointer for setexit continue
5954: r$cod: .long 0 # pointer to current cdblk or exblk
5955: r$ctp: .long 0 # ptr to current ctblk for patst
5956: r$ert: .long 0 # trblk pointer for errtype trace
5957: r$etx: .long nulls # pointer to errtext string
5958: r$exs: .long 0 # = save xl in expdm
5959: r$fcb: .long 0 # fcblk chain head
5960: r$fnc: .long 0 # trblk pointer for fnclevel trace
5961: r$gtc: .long 0 # keep code ptr for gtcod,gtexp
5962: r$io1: .long 0 # file arg1 for ioput
5963: r$io2: .long 0 # file arg2 for ioput
5964: r$iof: .long 0 # fcblk ptr or 0
5965: r$ion: .long 0 # name base ptr
5966: r$iop: .long 0 # predecessor block ptr for ioput
5967: r$iot: .long 0 # trblk ptr for ioput
5968: r$pmb: .long 0 # buffer ptr in pattern match
5969: r$pms: .long 0 # subject string ptr in pattern match
5970: r$ra2: .long 0 # replace second argument last time
5971: r$ra3: .long 0 # replace third argument last time
5972: r$rpt: .long 0 # ptr to ctblk replace table last usd
5973: r$scp: .long 0 # save pointer from last scane call
5974: r$sxl: .long 0 # preserve xl in sortc
5975: r$sxr: .long 0 # preserve xr in sorta/sortc
5976: r$stc: .long 0 # trblk pointer for stcount trace
5977: r$stl: .long 0 # source listing sub-title
5978: r$sxc: .long 0 # code (cdblk) ptr for setexit trap
5979: r$ttl: .long nulls # source listing title
5980: r$xsc: .long 0 # string pointer for xscan
5981: #page
5982: #
5983: # THE REMAINING POINTERS IN THIS LIST ARE USED TO POINT
5984: # TO FUNCTION BLOCKS FOR NORMALLY UNDEFINED OPERATORS.
5985: #
5986: r$uba: .long stndo # binary at
5987: r$ubm: .long stndo # binary ampersand
5988: r$ubn: .long stndo # binary number sign
5989: r$ubp: .long stndo # binary percent
5990: r$ubt: .long stndo # binary not
5991: r$uub: .long stndo # unary vertical bar
5992: r$uue: .long stndo # unary equal
5993: r$uun: .long stndo # unary number sign
5994: r$uup: .long stndo # unary percent
5995: r$uus: .long stndo # unary slash
5996: r$uux: .long stndo # unary exclamation
5997: r$yyy: .long 0 # last relocatable location
5998: #
5999: # WORK AREAS FOR SUBSTR FUNCTION (S$SUB)
6000: #
6001: sbssv: .long 0 # save third argument
6002: #
6003: # GLOBAL LOCATIONS USED IN SCAN PROCEDURE
6004: #
6005: scnbl: .long 0 # set non-zero if scanned past blanks
6006: scncc: .long 0 # non-zero to scan control card name
6007: scngo: .long 0 # set non-zero to scan goto field
6008: scnil: .long 0 # length of current input image
6009: scnpt: .long 0 # pointer to next location in r$cim
6010: scnrs: .long 0 # set non-zero to signal rescan
6011: scntp: .long 0 # save syntax type from last call
6012: #
6013: # WORK AREAS FOR SCAN PROCEDURE
6014: #
6015: scnsa: .long 0 # save wa
6016: scnsb: .long 0 # save wb
6017: scnsc: .long 0 # save wc
6018: scnse: .long 0 # start of current element
6019: scnof: .long 0 # save offset
6020: #page
6021: #
6022: # WORK AREA USED BY SORTA, SORTC, SORTF, SORTH
6023: #
6024: srtdf: .long 0 # datatype field name
6025: srtfd: .long 0 # found dfblk address
6026: srtff: .long 0 # found field name
6027: srtfo: .long 0 # offset to field name
6028: srtnr: .long 0 # number of rows
6029: srtof: .long 0 # offset within row to sort key
6030: srtrt: .long 0 # root offset
6031: srts1: .long 0 # save offset 1
6032: srts2: .long 0 # save offset 2
6033: srtsc: .long 0 # save wc
6034: srtsf: .long 0 # sort array first row offset
6035: srtsn: .long 0 # save n
6036: srtso: .long 0 # offset to a(0)
6037: srtsr: .long 0 # 0 , non-zero for sort, rsort
6038: srtst: .long 0 # stride from one row to next
6039: srtwc: .long 0 # dump wc
6040: #
6041: # GLOBAL VALUE FOR INDICATING STAGE (SEE ERROR SECTION)
6042: #
6043: stage: .long 0 # initial value = initial compile
6044: #
6045: # GLOBAL VALUES DEFINING EXTENT OF STATIC AREA (ALOST)
6046: #
6047: statb: .long 0 # start of static area
6048: state: .long 0 # end of static area
6049: #page
6050: #
6051: # GLOBAL STACK POINTER
6052: #
6053: stbas: .long 0 # pointer past stack base
6054: #
6055: # WORK AREAS FOR STOPR ROUTINE
6056: #
6057: stpsi: .long 0 # save value of stcount
6058: stpti: .long 0 # save time elapsed
6059: #
6060: # GLOBAL VALUES FOR SETEXIT FUNCTION (S$STX)
6061: #
6062: stxof: .long 0 # failure offset
6063: stxvr: .long nulls # vrblk pointer or null
6064: #
6065: # WORK AREAS FOR TFIND PROCEDURE
6066: #
6067: tfnsi: .long 0 # number of headers
6068: #
6069: # GLOBAL VALUE FOR TIME KEEPING
6070: #
6071: timsx: .long 0 # time at start of execution
6072: timup: .long 0 # set when time up occurs
6073: #
6074: # WORK AREAS FOR XSCAN PROCEDURE
6075: #
6076: xscrt: .long 0 # save return code
6077: xscwb: .long 0 # save register wb
6078: #
6079: # GLOBAL VALUES FOR XSCAN AND XSCNI PROCEDURES
6080: #
6081: xsofs: .long 0 # offset to current location in r$xsc
6082: #
6083: # LABEL TO MARK END OF WORK AREA
6084: #
6085: yyyyy: .long 0
6086: #title s p i t b o l -- initialization
6087: #
6088: # INITIALISATION
6089: # THE FOLLOWING SECTION RECEIVES CONTROL FROM THE SYSTEM
6090: # AT THE START OF A RUN WITH THE REGISTERS SET AS FOLLOWS.
6091: #
6092: # (XS) POINTS PAST STACK BASE
6093: # (XR) POINTS TO FIRST WORD OF DATA AREA
6094: # (XL) POINTS TO LAST WORD OF DATA AREA
6095: #
6096: .text 0
6097: .globl sec04
6098: sec04:
6099: #sec # start of program section
6100: jsb systm # initialise timer
6101: #
6102: # INITIALISE WORK AREA (ESSENTIAL FOR BATCHED RUNS)
6103: #
6104: movl r9,r7 # preserve xr
6105: movl $yyyyy,r6 # point to end of work area
6106: subl2 $aaaaa,r6 # get length of work area
6107: ashl $-2,r6,r6 # convert to words
6108: # count for loop
6109: movl $aaaaa,r9 # set up index register
6110: #
6111: # CLEAR WORK SPACE
6112: #
6113: ini01: clrl (r9)+ # clear a word
6114: sobgtr r6,ini01 # loop till done
6115: movl $stndo,r6 # undefined operators pointer
6116: movl $r$yyy,r8 # point to table end
6117: subl2 $r$uba,r8 # length of undef. operators table
6118: ashl $-2,r8,r8 # convert to words
6119: # loop counter
6120: movl $r$uba,r9 # set up xr
6121: #
6122: # SET CORRECT VALUE INTO UNDEFINED OPERATORS TABLE
6123: #
6124: ini02: movl r6,(r9)+ # store value
6125: sobgtr r8,ini02 # loop till all done
6126: movl $num01,r6 # get a 1
6127: movl r6,cmpsn # statement no
6128: movl r6,cswfl # nofail
6129: movl r6,cswls # list
6130: movl r6,kvinp # input
6131: movl r6,kvoup # output
6132: movl r6,lstpf # nothing for listr yet
6133: movl $iniln,r6 # input image length
6134: movl r6,cswin # -in72
6135: movl $b$kvt,dmpkb # dump
6136: movl $trbkv,dmpkt # dump
6137: movl $p$len,evlin # eval
6138: #page
6139: movl $nulls,r6 # get nullstring pointer
6140: movl r6,kvrtn # return
6141: movl r6,r$etx # errtext
6142: movl r6,r$ttl # title for listing
6143: movl r6,stxvr # setexit
6144: movl r5,timsx # store time in correct place
6145: movl stlim,r5 # get default stlimit
6146: movl r5,kvstl # statement limit
6147: movl r5,kvstc # statement count
6148: movl r7,statb # store start adrs of static
6149: movl $4*e$srs,rsmem # reserve memory
6150: movl sp,stbas # store stack base
6151: #sss iniss # save s-r stack ptr
6152: #
6153: # NOW CONVERT FREE STORE PERCENTAGE TO A SUITABLE FACTOR
6154: # FOR EASY TESTING IN ALLOC ROUTINE.
6155: #
6156: movl intvh,r5 # get 100
6157: divl2 alfsp,r5 # form 100 / alfsp
6158: movl r5,alfsf # store the factor
6159: #
6160: # INITIALIZE VALUES FOR REAL CONVERSION ROUTINE
6161: #
6162: movl $cfp$s,r7 # load counter for significant digits
6163: movf reav1,r2 # load 1.0
6164: #
6165: # LOOP TO COMPUTE 10**(MAX NUMBER SIGNIFICANT DIGITS)
6166: #
6167: ini03: mulf2 reavt,r2 # * 10.0
6168: sobgtr r7,ini03 # loop till done
6169: movf r2,gtssc # store 10**(max sig digits)
6170: movf reap5,r2 # load 0.5
6171: divf2 gtssc,r2 # compute 0.5*10**(max sig digits)
6172: movf r2,gtsrn # store as rounding bias
6173: clrl r8 # set to read parameters
6174: jsb prpar # read them
6175: #page
6176: #
6177: # NOW COMPUTE STARTING ADDRESS FOR DYNAMIC STORE AND IF
6178: # NECESSARY REQUEST MORE MEMORY.
6179: #
6180: subl2 $4*e$srs,r10 # allow for reserve memory
6181: movl prlen,r6 # get print buffer length
6182: addl2 $cfp$a,r6 # add no. of chars in alphabet
6183: addl2 $nstmx,r6 # add chars for gtstg bfr
6184: movab 3+(4*8)(r6),r6 # convert to bytes, allowing a margin
6185: bicl2 $3,r6
6186: movl statb,r9 # point to static base
6187: addl2 r6,r9 # increment for above buffers
6188: addl2 $4*e$hnb,r9 # increment for hash table
6189: addl2 $4*e$sts,r9 # bump for initial static block
6190: jsb sysmx # get mxlen
6191: movl r6,kvmxl # provisionally store as maxlngth
6192: movl r6,mxlen # and as mxlen
6193: cmpl r9,r6 # skip if static hi exceeds mxlen
6194: bgtru ini06
6195: movl r6,r9 # use mxlen instead
6196: addl2 $4,r9 # make bigger than mxlen
6197: #
6198: # HERE TO STORE VALUES WHICH MARK INITIAL DIVISION
6199: # OF DATA AREA INTO STATIC AND DYNAMIC
6200: #
6201: ini06: movl r9,dnamb # dynamic base adrs
6202: movl r9,dnamp # dynamic ptr
6203: tstl r6 # skip if non-zero mxlen
6204: bnequ ini07
6205: subl2 $4,r9 # point a word in front
6206: movl r9,kvmxl # use as maxlngth
6207: movl r9,mxlen # and as mxlen
6208: #page
6209: #
6210: # LOOP HERE IF NECESSARY TILL ENOUGH MEMORY OBTAINED
6211: # SO THAT DNAME IS ABOVE DNAMB
6212: #
6213: ini07: movl r10,dname # store dynamic end address
6214: cmpl dnamb,r10 # skip if high enough
6215: blssu ini09
6216: jsb sysmm # request more memory
6217: moval 0[r9],r9 # get as baus (sgd05)
6218: addl2 r9,r10 # bump by amount obtained
6219: tstl r9 # try again
6220: bnequ ini07
6221: movl $endmo,r9 # point to failure message
6222: movl endml,r6 # message length
6223: jsb syspr # print it (prtst not yet usable)
6224: .long invalid$ # should not fail
6225: jsb sysej # pack up (stopr not yet usable)
6226: #
6227: # INITIALISE PRINT BUFFER WITH BLANK WORDS
6228: #
6229: ini09: movl prlen,r8 # no. of chars in print bfr
6230: movl statb,r9 # point to static again
6231: movl r9,prbuf # print bfr is put at static start
6232: movl $b$scl,(r9)+ # store string type code
6233: movl r8,(r9)+ # and string length
6234: movab 3+(4*0)(r8),r8 # get number of words in buffer
6235: ashl $-2,r8,r8
6236: movl r8,prlnw # store for buffer clear
6237: # words to clear
6238: #
6239: # LOOP TO CLEAR BUFFER
6240: #
6241: ini10: movl nullw,(r9)+ # store blank
6242: sobgtr r8,ini10 # loop
6243: #
6244: # INITIALIZE NUMBER OF HASH HEADERS
6245: #
6246: movl $e$hnb,r6 # get number of hash headers
6247: movl r6,r5 # convert to integer
6248: movl r5,hshnb # store for use by gtnvr procedure
6249: # counter for clearing hash table
6250: movl r9,hshtb # pointer to hash table
6251: #
6252: # LOOP TO CLEAR HASH TABLE
6253: #
6254: ini11: clrl (r9)+ # blank a word
6255: sobgtr r6,ini11 # loop
6256: movl r9,hshte # end of hash table adrs is kept
6257: #
6258: # ALLOCATE WORK AREA FOR GTSTG CONVERSION PROCEDURE
6259: #
6260: movl $nstmx,r6 # get max num chars in output number
6261: movab 3+(4*scsi$)(r6),r6 # no of bytes needed
6262: bicl2 $3,r6
6263: movl r9,gtswk # store bfr adrs
6264: addl2 r6,r9 # bump for work bfr
6265: #page
6266: #
6267: # BUILD ALPHABET STRING FOR ALPHABET KEYWORD AND REPLACE
6268: #
6269: movl r9,kvalp # save alphabet pointer
6270: movl $b$scl,(r9) # string blk type
6271: movl $cfp$a,r8 # no of chars in alphabet
6272: movl r8,4*sclen(r9) # store as string length
6273: movl r8,r7 # copy char count
6274: movab 3+(4*scsi$)(r7),r7 # no. of bytes needed
6275: bicl2 $3,r7
6276: addl2 r9,r7 # current end address for static
6277: movl r7,state # store static end adrs
6278: # loop counter
6279: movab cfp$f(r9),r9 # point to chars of string
6280: clrl r7 # set initial character value
6281: #
6282: # LOOP TO ENTER CHARACTER CODES IN ORDER
6283: #
6284: ini12: movb r7,(r9)+ # store next code
6285: incl r7 # bump code value
6286: sobgtr r8,ini12 # loop till all stored
6287: #csc r9 # complete store characters
6288: #
6289: # INITIALIZE VARIABLE BLOCKS FOR INPUT AND OUTPUT
6290: #
6291: movl $v$inp,r10 # point to string /input/
6292: movl $trtin,r7 # trblk type for input
6293: jsb inout # perform input association
6294: movl $v$oup,r10 # point to string /output/
6295: movl $trtou,r7 # trblk type for output
6296: jsb inout # perform output association
6297: movl initr,r8 # terminal flag
6298: beqlu ini13 # skip if no terminal
6299: jsb prpar # associate terminal
6300: #page
6301: #
6302: # CHECK FOR EXPIRY DATE
6303: #
6304: ini13: jsb sysdc # call date check
6305: movl sp,flptr # in case stack overflows in compiler
6306: #
6307: # NOW COMPILE SOURCE INPUT CODE
6308: #
6309: jsb cmpil # call compiler
6310: movl r9,r$cod # set ptr to first code block
6311: movl $nulls,r$ttl # forget title (reg04)
6312: movl $nulls,r$stl # forget sub-title (reg04)
6313: clrl r$cim # forget compiler input image
6314: clrl r10 # clear dud value
6315: clrl r7 # dont shift dynamic store up
6316: jsb gbcol # clear garbage left from compile
6317: tstl cpsts # skip if no listing of comp stats
6318: beqlu 0f
6319: jmp inix0
6320: 0:
6321: jsb prtpg # eject page
6322: #
6323: # PRINT COMPILE STATISTICS
6324: #
6325: movl dnamp,r6 # next available loc
6326: subl2 statb,r6 # minus start
6327: ashl $-2,r6,r6 # convert to words
6328: movl r6,r5 # convert to integer
6329: movl $encm1,r9 # point to /memory used (words)/
6330: jsb prtmi # print message
6331: movl dname,r6 # end of memory
6332: subl2 dnamp,r6 # minus next available loc
6333: ashl $-2,r6,r6 # convert to words
6334: movl r6,r5 # convert to integer
6335: movl $encm2,r9 # point to /memory available (words)/
6336: jsb prtmi # print line
6337: movl cmerc,r5 # get count of errors as integer
6338: movl $encm3,r9 # point to /compile errors/
6339: jsb prtmi # print it
6340: movl gbcnt,r5 # garbage collection count
6341: subl2 intv1,r5 # adjust for unavoidable collect
6342: movl $stpm5,r9 # point to /storage regenerations/
6343: jsb prtmi # print gbcol count
6344: jsb systm # get time
6345: subl2 timsx,r5 # get compilation time
6346: movl $encm4,r9 # point to compilation time (msec)/
6347: jsb prtmi # print message
6348: addl2 $num05,lstlc # bump line count
6349: tstl headp # no eject if nothing printed (sdg11)
6350: bnequ 0f
6351: jmp inix0
6352: 0:
6353: jsb prtpg # eject printer
6354: #page
6355: #
6356: # PREPARE NOW TO START EXECUTION
6357: #
6358: # SET DEFAULT INPUT RECORD LENGTH
6359: #
6360: inix0: cmpl cswin,$iniln # skip if not default -in72 used
6361: bgtru inix1
6362: movl $inils,cswin # else use default record length
6363: #
6364: # RESET TIMER
6365: #
6366: inix1: jsb systm # get time again
6367: movl r5,timsx # store for end run processing
6368: addl2 cswex,noxeq # add -noexecute flag
6369: bnequ inix2 # jump if execution suppressed
6370: clrl gbcnt # initialise collect count
6371: jsb sysbx # call before starting execution
6372: #
6373: # MERGE WHEN LISTING FILE SET FOR EXECUTION
6374: #
6375: iniy0: movl sp,headp # mark headers out regardless
6376: clrl -(sp) # set failure location on stack
6377: movl sp,flptr # save ptr to failure offset word
6378: movl r$cod,r9 # load ptr to entry code block
6379: movl $stgxt,stage # set stage for execute time
6380: movl cmpsn,pfnte # copy stmts compiled count in case
6381: jsb systm # time yet again
6382: movl r5,pfstm
6383: movl (r9),r11 # start xeq with first statement
6384: jmp (r11)
6385: #
6386: # HERE IF EXECUTION IS SUPPRESSED
6387: #
6388: inix2: jsb prtnl # print a blank line
6389: movl $encm5,r9 # point to /execution suppressed/
6390: jsb prtst # print string
6391: jsb prtnl # output line
6392: clrl r6 # set abend value to zero
6393: movl $nini9,r7 # set special code value
6394: jsb sysej # end of job, exit to system
6395: #title s p i t b o l -- snobol4 operator routines
6396: #
6397: # THIS SECTION INCLUDES ALL ROUTINES WHICH CAN BE ACCESSED
6398: # DIRECTLY FROM THE GENERATED CODE EXCEPT SYSTEM FUNCTIONS.
6399: #
6400: # ALL ROUTINES IN THIS SECTION START WITH A LABEL OF THE
6401: # FORM O$XXX WHERE XXX IS THREE LETTERS. THE GENERATED CODE
6402: # CONTAINS A POINTER TO THE APPROPRIATE ENTRY LABEL.
6403: #
6404: # SINCE THE GENERAL FORM OF THE GENERATED CODE CONSISTS OF
6405: # POINTERS TO BLOCKS WHOSE FIRST WORD IS THE ADDRESS OF THE
6406: # ACTUAL ENTRY POINT LABEL (O$XXX).
6407: #
6408: # THESE ROUTINES ARE IN ALPHABETICAL ORDER BY THEIR
6409: # ENTRY LABEL NAMES (I.E. BY THE XXX OF THE O$XXX NAME)
6410: #
6411: # THESE ROUTINES RECEIVE CONTROL AS FOLLOWS
6412: #
6413: # (CP) POINTER TO NEXT CODE WORD
6414: # (XS) CURRENT STACK POINTER
6415: #page
6416: #
6417: # BINARY PLUS (ADDITION)
6418: #
6419: o$add: # entry point
6420: jsb arith # fetch arithmetic operands
6421: .long er_001 # addition left operand is not numeric
6422: .long er_002 # addition right operand is not numeric
6423: .long oadd1 # jump if real operands
6424: #
6425: # HERE TO ADD TWO INTEGERS
6426: #
6427: addl2 4*icval(r10),r5 # add right operand to left
6428: bvs 0f
6429: jmp exint
6430: 0:
6431: jmp er_003 # addition caused integer overflow
6432: #
6433: # HERE TO ADD TWO REALS
6434: #
6435: oadd1: addf2 4*rcval(r10),r2 # add right operand to left
6436: bvs 0f
6437: jmp exrea
6438: 0:
6439: jmp er_261 # addition caused real overflow
6440: #page
6441: #
6442: # UNARY PLUS (AFFIRMATION)
6443: #
6444: o$aff: # entry point
6445: movl (sp)+,r9 # load operand
6446: jsb gtnum # convert to numeric
6447: .long er_004 # affirmation operand is not numeric
6448: jmp exixr # return if converted to numeric
6449: #page
6450: #
6451: # BINARY BAR (ALTERNATION)
6452: #
6453: o$alt: # entry point
6454: movl (sp)+,r9 # load right operand
6455: jsb gtpat # convert to pattern
6456: .long er_005 # alternation right operand is not pattern
6457: #
6458: # MERGE HERE FROM SPECIAL (LEFT ALTERNATION) CASE
6459: #
6460: oalt1: movl $p$alt,r7 # set pcode for alternative node
6461: jsb pbild # build alternative node
6462: movl r9,r10 # save address of alternative node
6463: movl (sp)+,r9 # load left operand
6464: jsb gtpat # convert to pattern
6465: .long er_006 # alternation left operand is not pattern
6466: cmpl r9,$p$alt # jump if left arg is alternation
6467: beqlu oalt2
6468: movl r9,4*pthen(r10) # set left operand as successor
6469: movl r10,r9 # move result to proper register
6470: jmp exixr # jump for next code word
6471: #
6472: # COME HERE IF LEFT ARGUMENT IS ITSELF AN ALTERNATION
6473: #
6474: # THE RESULT IS MORE EFFICIENT IF WE MAKE THE REPLACEMENT
6475: #
6476: # (A / B) / C = A / (B / C)
6477: #
6478: oalt2: movl 4*parm1(r9),4*pthen(r10) # build the (b / c) node
6479: movl 4*pthen(r9),-(sp)# set a as new left arg
6480: movl r10,r9 # set (b / c) as new right arg
6481: jmp oalt1 # merge back to build a / (b / c)
6482: #page
6483: #
6484: # ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY NAME)
6485: #
6486: o$amn: # entry point
6487: movl (r3)+,r9 # load number of subscripts
6488: movl r9,r7 # set flag for by name
6489: jmp arref # jump to array reference routine
6490: #page
6491: #
6492: # ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY VALUE)
6493: #
6494: o$amv: # entry point
6495: movl (r3)+,r9 # load number of subscripts
6496: clrl r7 # set flag for by value
6497: jmp arref # jump to array reference routine
6498: #page
6499: #
6500: # ARRAY REFERENCE (ONE SUBSCRIPT, BY NAME)
6501: #
6502: o$aon: # entry point
6503: movl (sp),r9 # load subscript value
6504: movl 4*1(sp),r10 # load array value
6505: movl (r10),r6 # load first word of array operand
6506: cmpl r6,$b$vct # jump if vector reference
6507: beqlu oaon2
6508: cmpl r6,$b$tbt # jump if table reference
6509: beqlu oaon3
6510: #
6511: # HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
6512: #
6513: oaon1: movl $num01,r9 # set number of subscripts to one
6514: movl r9,r7 # set flag for by name
6515: jmp arref # jump to array reference routine
6516: #
6517: # HERE IF WE HAVE A VECTOR REFERENCE
6518: #
6519: oaon2: cmpl (r9),$b$icl # use long routine if not integer
6520: bnequ oaon1
6521: movl 4*icval(r9),r5 # load integer subscript value
6522: movl r5,r6 # copy as address int, fail if ovflo
6523: bgeq 0f
6524: jmp exfal
6525: 0:
6526: tstl r6 # fail if zero
6527: bnequ 0f
6528: jmp exfal
6529: 0:
6530: addl2 $vcvlb,r6 # compute offset in words
6531: moval 0[r6],r6 # convert to bytes
6532: movl r6,(sp) # complete name on stack
6533: cmpl r6,4*vclen(r10) # exit if subscript not too large
6534: bgequ 0f
6535: jmp exits
6536: 0:
6537: jmp exfal # else fail
6538: #
6539: # HERE FOR TABLE REFERENCE
6540: #
6541: oaon3: movl sp,r7 # set flag for name reference
6542: jsb tfind # locate/create table element
6543: .long exfal # fail if access fails
6544: movl r10,4*1(sp) # store name base on stack
6545: movl r6,(sp) # store name offset on stack
6546: jmp exits # exit with result on stack
6547: #page
6548: #
6549: # ARRAY REFERENCE (ONE SUBSCRIPT, BY VALUE)
6550: #
6551: o$aov: # entry point
6552: movl (sp)+,r9 # load subscript value
6553: movl (sp)+,r10 # load array value
6554: movl (r10),r6 # load first word of array operand
6555: cmpl r6,$b$vct # jump if vector reference
6556: beqlu oaov2
6557: cmpl r6,$b$tbt # jump if table reference
6558: beqlu oaov3
6559: #
6560: # HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
6561: #
6562: oaov1: movl r10,-(sp) # restack array value
6563: movl r9,-(sp) # restack subscript
6564: movl $num01,r9 # set number of subscripts to one
6565: clrl r7 # set flag for value call
6566: jmp arref # jump to array reference routine
6567: #
6568: # HERE IF WE HAVE A VECTOR REFERENCE
6569: #
6570: oaov2: cmpl (r9),$b$icl # use long routine if not integer
6571: bnequ oaov1
6572: movl 4*icval(r9),r5 # load integer subscript value
6573: movl r5,r6 # move as one word int, fail if ovflo
6574: bgeq 0f
6575: jmp exfal
6576: 0:
6577: tstl r6 # fail if zero
6578: bnequ 0f
6579: jmp exfal
6580: 0:
6581: addl2 $vcvlb,r6 # compute offset in words
6582: moval 0[r6],r6 # convert to bytes
6583: cmpl r6,4*vclen(r10) # fail if subscript too large
6584: blssu 0f
6585: jmp exfal
6586: 0:
6587: jsb acess # access value
6588: .long exfal # fail if access fails
6589: jmp exixr # else return value to caller
6590: #
6591: # HERE FOR TABLE REFERENCE BY VALUE
6592: #
6593: oaov3: clrl r7 # set flag for value reference
6594: jsb tfind # call table search routine
6595: .long exfal # fail if access fails
6596: jmp exixr # exit with result in xr
6597: #page
6598: #
6599: # ASSIGNMENT
6600: #
6601: o$ass: # entry point
6602: #
6603: # O$RPL (PATTERN REPLACEMENT) MERGES HERE
6604: #
6605: oass0: movl (sp)+,r7 # load value to be assigned
6606: movl (sp)+,r6 # load name offset
6607: movl (sp),r10 # load name base
6608: movl r7,(sp) # store assigned value as result
6609: jsb asign # perform assignment
6610: .long exfal # fail if assignment fails
6611: jmp exits # exit with result on stack
6612: #page
6613: #
6614: # COMPILATION ERROR
6615: #
6616: o$cer: # entry point
6617: jmp er_007 # compilation error encountered during execution
6618: #page
6619: #
6620: # UNARY AT (CURSOR ASSIGNMENT)
6621: #
6622: o$cas: # entry point
6623: movl (sp)+,r8 # load name offset (parm2)
6624: movl (sp)+,r9 # load name base (parm1)
6625: movl $p$cas,r7 # set pcode for cursor assignment
6626: jsb pbild # build node
6627: jmp exixr # jump for next code word
6628: #page
6629: #
6630: # CONCATENATION
6631: #
6632: o$cnc: # entry point
6633: movl (sp),r9 # load right argument
6634: cmpl r9,$nulls # jump if right arg is null
6635: bnequ 0f
6636: jmp ocnc3
6637: 0:
6638: movl 4*1(sp),r10 # load left argument
6639: cmpl r10,$nulls # jump if left argument is null
6640: bnequ 0f
6641: jmp ocnc4
6642: 0:
6643: movl $b$scl,r6 # get constant to test for string
6644: cmpl r6,(r10) # jump if left arg not a string
6645: beqlu 0f
6646: jmp ocnc2
6647: 0:
6648: cmpl r6,(r9) # jump if right arg not a string
6649: beqlu 0f
6650: jmp ocnc2
6651: 0:
6652: #
6653: # MERGE HERE TO CONCATENATE TWO STRINGS
6654: #
6655: ocnc1: movl 4*sclen(r10),r6 # load left argument length
6656: addl2 4*sclen(r9),r6 # compute result length
6657: jsb alocs # allocate scblk for result
6658: movl r9,4*1(sp) # store result ptr over left argument
6659: movab cfp$f(r9),r9 # prepare to store chars of result
6660: movl 4*sclen(r10),r6 # get number of chars in left arg
6661: movab cfp$f(r10),r10 # prepare to load left arg chars
6662: jsb sbmvc # move characters of left argument
6663: movl (sp)+,r10 # load right arg pointer, pop stack
6664: movl 4*sclen(r10),r6 # load number of chars in right arg
6665: movab cfp$f(r10),r10 # prepare to load right arg chars
6666: jsb sbmvc # move characters of right argument
6667: jmp exits # exit with result on stack
6668: #
6669: # COME HERE IF ARGUMENTS ARE NOT BOTH STRINGS
6670: #
6671: ocnc2: jsb gtstg # convert right arg to string
6672: .long ocnc5 # jump if right arg is not string
6673: movl r9,r10 # save right arg ptr
6674: jsb gtstg # convert left arg to string
6675: .long ocnc6 # jump if left arg is not a string
6676: movl r9,-(sp) # stack left argument
6677: movl r10,-(sp) # stack right argument
6678: movl r9,r10 # move left arg to proper reg
6679: movl (sp),r9 # move right arg to proper reg
6680: jmp ocnc1 # merge back to concatenate strings
6681: #page
6682: #
6683: # CONCATENATION (CONTINUED)
6684: #
6685: # COME HERE FOR NULL RIGHT ARGUMENT
6686: #
6687: ocnc3: addl2 $4,sp # remove right arg from stack
6688: jmp exits # return with left argument on stack
6689: #
6690: # HERE FOR NULL LEFT ARGUMENT
6691: #
6692: ocnc4: addl2 $4,sp # unstack one argument
6693: movl r9,(sp) # store right argument
6694: jmp exits # exit with result on stack
6695: #
6696: # HERE IF RIGHT ARGUMENT IS NOT A STRING
6697: #
6698: ocnc5: movl r9,r10 # move right argument ptr
6699: movl (sp)+,r9 # load left arg pointer
6700: #
6701: # MERGE HERE WHEN LEFT ARGUMENT IS NOT A STRING
6702: #
6703: ocnc6: jsb gtpat # convert left arg to pattern
6704: .long er_008 # concatenation left opnd is not string or pattern
6705: movl r9,-(sp) # save result on stack
6706: movl r10,r9 # point to right operand
6707: jsb gtpat # convert to pattern
6708: .long er_009 # concatenation right opd is not string or pattern
6709: movl r9,r10 # move for pconc
6710: movl (sp)+,r9 # reload left operand ptr
6711: jsb pconc # concatenate patterns
6712: jmp exixr # exit with result in xr
6713: #page
6714: #
6715: # COMPLEMENTATION
6716: #
6717: o$com: # entry point
6718: movl (sp)+,r9 # load operand
6719: movl (r9),r6 # load type word
6720: #
6721: # MERGE BACK HERE AFTER CONVERSION
6722: #
6723: ocom1: cmpl r6,$b$icl # jump if integer
6724: beqlu ocom2
6725: cmpl r6,$b$rcl # jump if real
6726: beqlu ocom3
6727: jsb gtnum # else convert to numeric
6728: .long er_010 # complementation operand is not numeric
6729: jmp ocom1 # back to check cases
6730: #
6731: # HERE TO COMPLEMENT INTEGER
6732: #
6733: ocom2: movl 4*icval(r9),r5 # load integer value
6734: mnegl r5,r5 # negate
6735: bvs 0f
6736: jmp exint
6737: 0:
6738: jmp er_011 # complementation caused integer overflow
6739: #
6740: # HERE TO COMPLEMENT REAL
6741: #
6742: ocom3: movf 4*rcval(r9),r2 # load real value
6743: mnegf r2,r2 # negate
6744: jmp exrea # return real result
6745: #page
6746: #
6747: # BINARY SLASH (DIVISION)
6748: #
6749: o$dvd: # entry point
6750: jsb arith # fetch arithmetic operands
6751: .long er_012 # division left operand is not numeric
6752: .long er_013 # division right operand is not numeric
6753: .long odvd2 # jump if real operands
6754: #
6755: # HERE TO DIVIDE TWO INTEGERS
6756: #
6757: divl2 4*icval(r10),r5 # divide left operand by right
6758: bvs 0f
6759: jmp exint
6760: 0:
6761: jmp er_014 # division caused integer overflow
6762: #
6763: # HERE TO DIVIDE TWO REALS
6764: #
6765: odvd2: divf2 4*rcval(r10),r2 # divide left operand by right
6766: bvs 0f
6767: jmp exrea
6768: 0:
6769: jmp er_262 # division caused real overflow
6770: #page
6771: #
6772: # EXPONENTIATION
6773: #
6774: o$exp: # entry point
6775: movl (sp)+,r9 # load exponent
6776: jsb gtnum # convert to number
6777: .long er_015 # exponentiation right operand is not numeric
6778: cmpl r6,$b$icl # jump if real
6779: beqlu 0f
6780: jmp oexp7
6781: 0:
6782: movl r9,r10 # move exponent
6783: movl (sp)+,r9 # load base
6784: jsb gtnum # convert to numeric
6785: .long er_016 # exponentiation left operand is not numeric
6786: movl 4*icval(r10),r5 # load exponent
6787: bgeq 0f # error if negative exponent
6788: jmp oexp8
6789: 0:
6790: cmpl r6,$b$rcl # jump if base is real
6791: beqlu oexp3
6792: #
6793: # HERE TO EXPONENTIATE AN INTEGER
6794: #
6795: movl r5,r6 # convert exponent to 1 word integer
6796: bgeq 0f
6797: jmp oexp2
6798: 0:
6799: # set loop counter
6800: movl intv1,r5 # load initial value of 1
6801: tstl r6 # jump if non-zero exponent
6802: bnequ oexp1
6803: tstl r5 # give zero as result for nonzero**0
6804: beql 0f
6805: jmp exint
6806: 0:
6807: jmp oexp4 # else error of 0**0
6808: #
6809: # LOOP TO PERFORM EXPONENTIATION
6810: #
6811: oexp1: mull2 4*icval(r9),r5 # multiply by base
6812: bvs oexp2
6813: sobgtr r6,oexp1 # loop back till computation complete
6814: jmp exint # then return integer result
6815: #
6816: # HERE IF INTEGER OVERFLOW
6817: #
6818: oexp2: jmp er_017 # exponentiation caused integer overflow
6819: #page
6820: #
6821: # EXPONENTIATION (CONTINUED)
6822: #
6823: # HERE TO EXPONENTIATE A REAL
6824: #
6825: oexp3: movl r5,r6 # convert exponent to one word
6826: bgeq 0f
6827: jmp oexp6
6828: 0:
6829: # set loop counter
6830: movf reav1,r2 # load 1.0 as initial value
6831: tstl r6 # jump if non-zero exponent
6832: bnequ oexp5
6833: tstf r2 # return 1.0 if nonzero**zero
6834: beql 0f
6835: jmp exrea
6836: 0:
6837: #
6838: # HERE FOR ERROR OF 0**0 OR 0.0**0
6839: #
6840: oexp4: jmp er_018 # exponentiation result is undefined
6841: #
6842: # LOOP TO PERFORM EXPONENTIATION
6843: #
6844: oexp5: mulf2 4*rcval(r9),r2 # multiply by base
6845: bvs oexp6
6846: sobgtr r6,oexp5 # loop till computation complete
6847: jmp exrea # then return real result
6848: #
6849: # HERE IF REAL OVERFLOW
6850: #
6851: oexp6: jmp er_266 # exponentiation caused real overflow
6852: #
6853: # HERE IF REAL EXPONENT
6854: #
6855: oexp7: jmp er_267 # exponentiation right operand is real not integer
6856: #
6857: # HERE FOR NEGATIVE EXPONENT
6858: #
6859: oexp8: jmp er_019 # exponentiation right operand is negative
6860: #page
6861: #
6862: # FAILURE IN EXPRESSION EVALUATION
6863: #
6864: # THIS ENTRY POINT IS USED IF THE EVALUATION OF AN
6865: # EXPRESSION, INITIATED BY THE EVALX PROCEDURE, FAILS.
6866: # CONTROL IS RETURNED TO AN APPROPRIATE POINT IN EVALX.
6867: #
6868: o$fex: # entry point
6869: jmp evlx6 # jump to failure loc in evalx
6870: #page
6871: #
6872: # FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO
6873: #
6874: o$fif: # entry point
6875: jmp er_020 # goto evaluation failure
6876: #page
6877: #
6878: # FUNCTION CALL (MORE THAN ONE ARGUMENT)
6879: #
6880: o$fnc: # entry point
6881: movl (r3)+,r6 # load number of arguments
6882: movl (r3)+,r9 # load function vrblk pointer
6883: movl 4*vrfnc(r9),r10 # load function pointer
6884: cmpl r6,4*fargs(r10) # use central routine if wrong num
6885: beqlu 0f
6886: jmp cfunc
6887: 0:
6888: movl (r10),r11 # jump to function if arg count ok
6889: jmp (r11)
6890: #page
6891: #
6892: # FUNCTION NAME ERROR
6893: #
6894: o$fne: # entry point
6895: movl (r3)+,r6 # get next code word
6896: cmpl r6,$ornm$ # fail if not evaluating expression
6897: bnequ ofne1
6898: tstl 4*2(sp) # ok if expr. was wanted by value
6899: bnequ 0f
6900: jmp evlx3
6901: 0:
6902: #
6903: # HERE FOR ERROR
6904: #
6905: ofne1: jmp er_021 # function called by name returned a value
6906: #page
6907: #
6908: # FUNCTION CALL (SINGLE ARGUMENT)
6909: #
6910: o$fns: # entry point
6911: movl (r3)+,r9 # load function vrblk pointer
6912: movl $num01,r6 # set number of arguments to one
6913: movl 4*vrfnc(r9),r10 # load function pointer
6914: cmpl r6,4*fargs(r10) # use central routine if wrong num
6915: beqlu 0f
6916: jmp cfunc
6917: 0:
6918: movl (r10),r11 # jump to function if arg count ok
6919: jmp (r11)
6920: #page
6921: # CALL TO UNDEFINED FUNCTION
6922: #
6923: o$fun: # entry point
6924: jmp er_022 # undefined function called
6925: #page
6926: #
6927: # EXECUTE COMPLEX GOTO
6928: #
6929: o$goc: # entry point
6930: movl 4*1(sp),r9 # load name base pointer
6931: cmpl r9,state # jump if not natural variable
6932: bgequ ogoc1
6933: addl2 $4*vrtra,r9 # else point to vrtra field
6934: movl (r9),r11 # and jump through it
6935: jmp (r11)
6936: #
6937: # HERE IF GOTO OPERAND IS NOT NATURAL VARIABLE
6938: #
6939: ogoc1: jmp er_023 # goto operand is not a natural variable
6940: #page
6941: #
6942: # EXECUTE DIRECT GOTO
6943: #
6944: o$god: # entry point
6945: movl (sp),r9 # load operand
6946: movl (r9),r6 # load first word
6947: cmpl r6,$b$cds # jump if code block to code routine
6948: bnequ 0f
6949: jmp bcds0
6950: 0:
6951: cmpl r6,$b$cdc # jump if code block to code routine
6952: bnequ 0f
6953: jmp bcdc0
6954: 0:
6955: jmp er_024 # goto operand in direct goto is not code
6956: #page
6957: #
6958: # SET GOTO FAILURE TRAP
6959: #
6960: # THIS ROUTINE IS EXECUTED AT THE START OF A COMPLEX OR
6961: # DIRECT FAILURE GOTO TO TRAP A SUBSEQUENT FAIL (SEE EXFAL)
6962: #
6963: o$gof: # entry point
6964: movl flptr,r9 # point to fail offset on stack
6965: addl2 $4,(r9) # point failure to o$fif word
6966: tstl (r3)+ # point to next code word
6967: jmp exits # exit to continue
6968: #page
6969: #
6970: # BINARY DOLLAR (IMMEDIATE ASSIGNMENT)
6971: #
6972: # THE PATTERN BUILT BY BINARY DOLLAR IS A COMPOUND PATTERN.
6973: # SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR
6974: # DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED.
6975: #
6976: o$ima: # entry point
6977: movl $p$imc,r7 # set pcode for last node
6978: movl (sp)+,r8 # pop name offset (parm2)
6979: movl (sp)+,r9 # pop name base (parm1)
6980: jsb pbild # build p$imc node
6981: movl r9,r10 # save ptr to node
6982: movl (sp),r9 # load left argument
6983: jsb gtpat # convert to pattern
6984: .long er_025 # immediate assignment left operand is not pattern
6985: movl r9,(sp) # save ptr to left operand pattern
6986: movl $p$ima,r7 # set pcode for first node
6987: jsb pbild # build p$ima node
6988: movl (sp)+,4*pthen(r9)# set left operand as p$ima successor
6989: jsb pconc # concatenate to form final pattern
6990: jmp exixr # all done
6991: #page
6992: #
6993: # INDIRECTION (BY NAME)
6994: #
6995: o$inn: # entry point
6996: movl sp,r7 # set flag for result by name
6997: jmp indir # jump to common routine
6998: #page
6999: #
7000: # INTERROGATION
7001: #
7002: o$int: # entry point
7003: movl $nulls,(sp) # replace operand with null
7004: jmp exits # exit for next code word
7005: #page
7006: #
7007: # INDIRECTION (BY VALUE)
7008: #
7009: o$inv: # entry point
7010: clrl r7 # set flag for by value
7011: jmp indir # jump to common routine
7012: #page
7013: #
7014: # KEYWORD REFERENCE (BY NAME)
7015: #
7016: o$kwn: # entry point
7017: jsb kwnam # get keyword name
7018: jmp exnam # exit with result name
7019: #page
7020: #
7021: # KEYWORD REFERENCE (BY VALUE)
7022: #
7023: o$kwv: # entry point
7024: jsb kwnam # get keyword name
7025: movl r9,dnamp # delete kvblk
7026: jsb acess # access value
7027: .long exnul # dummy (unused) failure return
7028: jmp exixr # jump with value in xr
7029: #page
7030: #
7031: # LOAD EXPRESSION BY NAME
7032: #
7033: o$lex: # entry point
7034: movl $4*evsi$,r6 # set size of evblk
7035: jsb alloc # allocate space for evblk
7036: movl $b$evt,(r9) # set type word
7037: movl $trbev,4*evvar(r9) # set dummy trblk pointer
7038: movl (r3)+,r6 # load exblk pointer
7039: movl r6,4*evexp(r9) # set exblk pointer
7040: movl r9,r10 # move name base to proper reg
7041: movl $4*evvar,r6 # set name offset = zero
7042: jmp exnam # exit with name in (xl,wa)
7043: #page
7044: #
7045: # LOAD PATTERN VALUE
7046: #
7047: o$lpt: # entry point
7048: movl (r3)+,r9 # load pattern pointer
7049: jmp exixr # stack ptr and obey next code word
7050: #page
7051: #
7052: # LOAD VARIABLE NAME
7053: #
7054: o$lvn: # entry point
7055: movl (r3)+,r6 # load vrblk pointer
7056: movl r6,-(sp) # stack vrblk ptr (name base)
7057: movl $4*vrval,-(sp) # stack name offset
7058: jmp exits # exit with result on stack
7059: #page
7060: #
7061: # BINARY ASTERISK (MULTIPLICATION)
7062: #
7063: o$mlt: # entry point
7064: jsb arith # fetch arithmetic operands
7065: .long er_026 # multiplication left operand is not numeric
7066: .long er_027 # multiplication right operand is not numeric
7067: .long omlt1 # jump if real operands
7068: #
7069: # HERE TO MULTIPLY TWO INTEGERS
7070: #
7071: mull2 4*icval(r10),r5 # multiply left operand by right
7072: bvs 0f
7073: jmp exint
7074: 0:
7075: jmp er_028 # multiplication caused integer overflow
7076: #
7077: # HERE TO MULTIPLY TWO REALS
7078: #
7079: omlt1: mulf2 4*rcval(r10),r2 # multiply left operand by right
7080: bvs 0f
7081: jmp exrea
7082: 0:
7083: jmp er_263 # multiplication caused real overflow
7084: #page
7085: #
7086: # NAME REFERENCE
7087: #
7088: o$nam: # entry point
7089: movl $4*nmsi$,r6 # set length of nmblk
7090: jsb alloc # allocate nmblk
7091: movl $b$nml,(r9) # set name block code
7092: movl (sp)+,4*nmofs(r9)# set name offset from operand
7093: movl (sp)+,4*nmbas(r9)# set name base from operand
7094: jmp exixr # exit with result in xr
7095: #page
7096: #
7097: # NEGATION
7098: #
7099: # INITIAL ENTRY
7100: #
7101: o$nta: # entry point
7102: movl (r3)+,r6 # load new failure offset
7103: movl flptr,-(sp) # stack old failure pointer
7104: movl r6,-(sp) # stack new failure offset
7105: movl sp,flptr # set new failure pointer
7106: jmp exits # jump to continue execution
7107: #
7108: # ENTRY AFTER SUCCESSFUL EVALUATION OF OPERAND
7109: #
7110: o$ntb: # entry point
7111: movl 4*2(sp),flptr # restore old failure pointer
7112: jmp exfal # and fail
7113: #
7114: # ENTRY FOR FAILURE DURING OPERAND EVALUATION
7115: #
7116: o$ntc: # entry point
7117: addl2 $4,sp # pop failure offset
7118: movl (sp)+,flptr # restore old failure pointer
7119: jmp exnul # exit giving null result
7120: #page
7121: #
7122: # USE OF UNDEFINED OPERATOR
7123: #
7124: o$oun: # entry point
7125: jmp er_029 # undefined operator referenced
7126: #page
7127: #
7128: # BINARY DOT (PATTERN ASSIGNMENT)
7129: #
7130: # THE PATTERN BUILT BY BINARY DOT IS A COMPOUND PATTERN.
7131: # SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR
7132: # DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED.
7133: #
7134: o$pas: # entry point
7135: movl $p$pac,r7 # load pcode for p$pac node
7136: movl (sp)+,r8 # load name offset (parm2)
7137: movl (sp)+,r9 # load name base (parm1)
7138: jsb pbild # build p$pac node
7139: movl r9,r10 # save ptr to node
7140: movl (sp),r9 # load left operand
7141: jsb gtpat # convert to pattern
7142: .long er_030 # pattern assignment left operand is not pattern
7143: movl r9,(sp) # save ptr to left operand pattern
7144: movl $p$paa,r7 # set pcode for p$paa node
7145: jsb pbild # build p$paa node
7146: movl (sp)+,4*pthen(r9)# set left operand as p$paa successor
7147: jsb pconc # concatenate to form final pattern
7148: jmp exixr # jump for next code word
7149: #page
7150: #
7151: # PATTERN MATCH (BY NAME, FOR REPLACEMENT)
7152: #
7153: o$pmn: # entry point
7154: clrl r7 # set type code for match by name
7155: jmp match # jump to routine to start match
7156: #page
7157: #
7158: # PATTERN MATCH (STATEMENT)
7159: #
7160: # O$PMS IS USED IN PLACE OF O$PMV WHEN THE PATTERN MATCH
7161: # OCCURS AT THE OUTER (STATEMENT) LEVEL SINCE IN THIS
7162: # CASE THE SUBSTRING VALUE NEED NOT BE CONSTRUCTED.
7163: #
7164: o$pms: # entry point
7165: movl $num02,r7 # set flag for statement to match
7166: jmp match # jump to routine to start match
7167: #page
7168: #
7169: # PATTERN MATCH (BY VALUE)
7170: #
7171: o$pmv: # entry point
7172: movl $num01,r7 # set type code for value match
7173: jmp match # jump to routine to start match
7174: #page
7175: #
7176: # POP TOP ITEM ON STACK
7177: #
7178: o$pop: # entry point
7179: addl2 $4,sp # pop top stack entry
7180: jmp exits # obey next code word
7181: #page
7182: #
7183: # TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT)
7184: #
7185: o$stp: # entry point
7186: jmp lend0 # jump to end circuit
7187: #page
7188: #
7189: # RETURN NAME FROM EXPRESSION
7190: # THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN
7191: # EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS
7192: # A NAME. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX.
7193: #
7194: o$rnm: # entry point
7195: jmp evlx4 # return to evalx procedure
7196: #page
7197: #
7198: # PATTERN REPLACEMENT
7199: #
7200: # WHEN THIS ROUTINE GETS CONTROL, THE FOLLOWING STACK
7201: # ENTRIES HAVE BEEN MADE (SEE END OF MATCH ROUTINE P$NTH)
7202: #
7203: # SUBJECT NAME BASE
7204: # SUBJECT NAME OFFSET
7205: # INITIAL CURSOR VALUE
7206: # FINAL CURSOR VALUE
7207: # SUBJECT POINTER
7208: # (XS) ---------------- REPLACEMENT VALUE
7209: #
7210: o$rpl: # entry point
7211: jsb gtstg # convert replacement val to string
7212: .long er_031 # pattern replacement right operand is not string
7213: #
7214: # GET RESULT LENGTH AND ALLOCATE RESULT SCBLK
7215: #
7216: movl (sp),r10 # load subject string pointer
7217: cmpl (r10),$b$bct # branch if buffer assignment
7218: bnequ 0f
7219: jmp orpl4
7220: 0:
7221: addl2 4*sclen(r10),r6 # add subject string length
7222: addl2 4*2(sp),r6 # add starting cursor
7223: subl2 4*1(sp),r6 # minus final cursor = total length
7224: bnequ 0f # jump if result is null
7225: jmp orpl3
7226: 0:
7227: movl r9,-(sp) # restack replacement string
7228: jsb alocs # allocate scblk for result
7229: movl 4*3(sp),r6 # get initial cursor (part 1 len)
7230: movl r9,4*3(sp) # stack result pointer
7231: movab cfp$f(r9),r9 # point to characters of result
7232: #
7233: # MOVE PART 1 (START OF SUBJECT) TO RESULT
7234: #
7235: tstl r6 # jump if first part is null
7236: beqlu orpl1
7237: movl 4*1(sp),r10 # else point to subject string
7238: movab cfp$f(r10),r10 # point to subject string chars
7239: jsb sbmvc # move first part to result
7240: #page
7241: # PATTERN REPLACEMENT (CONTINUED)
7242: #
7243: # NOW MOVE IN REPLACEMENT VALUE
7244: #
7245: orpl1: movl (sp)+,r10 # load replacement string, pop
7246: movl 4*sclen(r10),r6 # load length
7247: beqlu orpl2 # jump if null replacement
7248: movab cfp$f(r10),r10 # else point to chars of replacement
7249: jsb sbmvc # move in chars (part 2)
7250: #
7251: # NOW MOVE IN REMAINDER OF STRING (PART 3)
7252: #
7253: orpl2: movl (sp)+,r10 # load subject string pointer, pop
7254: movl (sp)+,r8 # load final cursor, pop
7255: movl 4*sclen(r10),r6 # load subject string length
7256: subl2 r8,r6 # minus final cursor = part 3 length
7257: bnequ 0f # jump to assign if part 3 is null
7258: jmp oass0
7259: 0:
7260: movab cfp$f(r10)[r8],r10 # else point to last part of string
7261: jsb sbmvc # move part 3 to result
7262: jmp oass0 # jump to perform assignment
7263: #
7264: # HERE IF RESULT IS NULL
7265: #
7266: orpl3: addl2 $4*num02,sp # pop subject str ptr, final cursor
7267: movl $nulls,(sp) # set null result
7268: jmp oass0 # jump to assign null value
7269: #
7270: # HERE FOR BUFFER SUBSTRING ASSIGNMENT
7271: #
7272: orpl4: movl r9,r10 # copy scblk replacement ptr
7273: movl (sp)+,r9 # unstack bcblk ptr
7274: movl (sp)+,r7 # get final cursor value
7275: movl (sp)+,r6 # get initial cursor
7276: subl2 r6,r7 # get length in wb
7277: addl2 $4*num02,sp # get rid of name base/offset
7278: jsb insbf # insert substring
7279: .long invalid$ # convert fail impossible
7280: .long exfal # fail if insert fails
7281: jmp exnul # else null result
7282: #page
7283: #
7284: # RETURN VALUE FROM EXPRESSION
7285: #
7286: # THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN
7287: # EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS
7288: # A VALUE. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX
7289: #
7290: o$rvl: # entry point
7291: jmp evlx3 # return to evalx procedure
7292: #page
7293: #
7294: # SELECTION
7295: #
7296: # INITIAL ENTRY
7297: #
7298: o$sla: # entry point
7299: movl (r3)+,r6 # load new failure offset
7300: movl flptr,-(sp) # stack old failure pointer
7301: movl r6,-(sp) # stack new failure offset
7302: movl sp,flptr # set new failure pointer
7303: jmp exits # jump to execute first alternative
7304: #
7305: # ENTRY AFTER SUCCESSFUL EVALUATION OF ALTERNATIVE
7306: #
7307: o$slb: # entry point
7308: movl (sp)+,r9 # load result
7309: addl2 $4,sp # pop fail offset
7310: movl (sp),flptr # restore old failure pointer
7311: movl r9,(sp) # restack result
7312: movl (r3)+,r6 # load new code offset
7313: addl2 r$cod,r6 # point to absolute code location
7314: movl r6,r3 # set new code pointer
7315: jmp exits # jump to continue past selection
7316: #
7317: # ENTRY AT START OF SUBSEQUENT ALTERNATIVES
7318: #
7319: o$slc: # entry point
7320: movl (r3)+,r6 # load new fail offset
7321: movl r6,(sp) # store new fail offset
7322: jmp exits # jump to execute next alternative
7323: #
7324: # ENTRY AT START OF LAST ALTERNATIVE
7325: #
7326: o$sld: # entry point
7327: addl2 $4,sp # pop failure offset
7328: movl (sp)+,flptr # restore old failure pointer
7329: jmp exits # jump to execute last alternative
7330: #page
7331: #
7332: # BINARY MINUS (SUBTRACTION)
7333: #
7334: o$sub: # entry point
7335: jsb arith # fetch arithmetic operands
7336: .long er_032 # subtraction left operand is not numeric
7337: .long er_033 # subtraction right operand is not numeric
7338: .long osub1 # jump if real operands
7339: #
7340: # HERE TO SUBTRACT TWO INTEGERS
7341: #
7342: subl2 4*icval(r10),r5 # subtract right operand from left
7343: bvs 0f
7344: jmp exint
7345: 0:
7346: jmp er_034 # subtraction caused integer overflow
7347: #
7348: # HERE TO SUBTRACT TWO REALS
7349: #
7350: osub1: subf2 4*rcval(r10),r2 # subtract right operand from left
7351: bvs 0f
7352: jmp exrea
7353: 0:
7354: jmp er_264 # subtraction caused real overflow
7355: #page
7356: #
7357: # DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE
7358: #
7359: o$txr: # entry point
7360: jmp trxq1 # jump into trxeq procedure
7361: #page
7362: #
7363: # UNEXPECTED FAILURE
7364: #
7365: # NOTE THAT IF A SETEXIT TRAP IS OPERATING THEN
7366: # TRANSFER TO SYSTEM LABEL CONTINUE
7367: # WILL RESULT IN LOOPING HERE. DIFFICULT TO AVOID EXCEPT
7368: # WITH A CONSIDERABLE OVERHEAD WHICH IS NOT WORTHWHILE OR
7369: # ELSE BY A TECHNIQUE SUCH AS SETTING KVERL TO ZERO.
7370: #
7371: o$unf: # entry point
7372: jmp er_035 # unexpected failure in -nofail mode
7373: #title s p i t b o l -- snobol4 builtin label routines
7374: #
7375: # THE FOLLOWING SECTION CONTAINS THE ROUTINES FOR LABELS
7376: # WHICH HAVE A PREDEFINED MEANING IN SNOBOL4.
7377: #
7378: # CONTROL IS PASSED DIRECTLY TO THE LABEL NAME ENTRY POINT.
7379: #
7380: # ENTRY NAMES ARE OF THE FORM L$XXX WHERE XXX IS THE THREE
7381: # LETTER VARIABLE NAME IDENTIFIER.
7382: #
7383: # ENTRIES ARE IN ALPHABETICAL ORDER
7384: #page
7385: #
7386: # ABORT
7387: #
7388: l$abo: # entry point
7389: #
7390: # MERGE HERE IF EXECUTION TERMINATES IN ERROR
7391: #
7392: labo1: movl kvert,r6 # load error code
7393: beqlu labo2 # jump if no error has occured
7394: jsb sysax # call after execution proc (reg04)
7395: jsb prtpg # else eject printer
7396: jsb ermsg # print error message
7397: clrl r9 # indicate no message to print
7398: jmp stopr # jump to routine to stop run
7399: #
7400: # HERE IF NO ERROR HAD OCCURED
7401: #
7402: labo2: jmp er_036 # goto abort with no preceding error
7403: #page
7404: #
7405: # CONTINUE
7406: #
7407: l$cnt: # entry point
7408: #
7409: # MERGE HERE AFTER EXECUTION ERROR
7410: #
7411: lcnt1: movl r$cnt,r9 # load continuation code block ptr
7412: beqlu lcnt2 # jump if no previous error
7413: clrl r$cnt # clear flag
7414: movl r9,r$cod # else store as new code block ptr
7415: addl2 stxof,r9 # add failure offset
7416: movl r9,r3 # load code pointer
7417: movl flptr,sp # reset stack pointer
7418: jmp exits # jump to take indicated failure
7419: #
7420: # HERE IF NO PREVIOUS ERROR
7421: #
7422: lcnt2: jmp er_037 # goto continue with no preceding error
7423: #page
7424: #
7425: # END
7426: #
7427: l$end: # entry point
7428: #
7429: # MERGE HERE FROM END CODE CIRCUIT
7430: #
7431: lend0: movl $endms,r9 # point to message /normal term../
7432: jmp stopr # jump to routine to stop run
7433: #page
7434: #
7435: # FRETURN
7436: #
7437: l$frt: # entry point
7438: movl $scfrt,r6 # point to string /freturn/
7439: jmp retrn # jump to common return routine
7440: #page
7441: #
7442: # NRETURN
7443: #
7444: l$nrt: # entry point
7445: movl $scnrt,r6 # point to string /nreturn/
7446: jmp retrn # jump to common return routine
7447: #page
7448: #
7449: # RETURN
7450: #
7451: l$rtn: # entry point
7452: movl $scrtn,r6 # point to string /return/
7453: jmp retrn # jump to common return routine
7454: #page
7455: #
7456: # UNDEFINED LABEL
7457: #
7458: l$und: # entry point
7459: jmp er_038 # goto undefined label
7460: #title s p i t b o l -- block action routines
7461: #
7462: # THE FIRST WORD OF EVERY BLOCK IN DYNAMIC STORAGE AND THE
7463: # VRGET, VRSTO AND VRTRA FIELDS OF A VRBLK CONTAIN A
7464: # POINTER TO AN ENTRY POINT IN THE PROGRAM. ALL SUCH ENTRY
7465: # POINTS ARE IN THE FOLLOWING SECTION EXCEPT THOSE FOR
7466: # PATTERN BLOCKS WHICH ARE IN THE PATTERN MATCHING SEGMENT
7467: # LATER ON (LABELS OF THE FORM P$XXX), AND DOPE VECTORS
7468: # (D$XXX) WHICH ARE IN THE DOPE VECTOR SECTION FOLLOWING
7469: # THE PATTERN ROUTINES (DOPE VECTORS ARE USED FOR CMBLKS).
7470: #
7471: # THE ENTRY POINTS IN THIS SECTION HAVE LABELS OF THE
7472: # FORM B$XXY WHERE XX IS THE TWO CHARACTER BLOCK TYPE FOR
7473: # THE CORRESPONDING BLOCK AND Y IS ANY LETTER.
7474: #
7475: # IN SOME CASES, THE POINTERS SERVE NO OTHER PURPOSE THAN
7476: # TO IDENTIFY THE BLOCK TYPE. IN THIS CASE THE ROUTINE
7477: # IS NEVER EXECUTED AND THUS NO CODE IS ASSEMBLED.
7478: #
7479: # FOR EACH OF THESE ENTRY POINTS CORRESPONDING TO A BLOCK
7480: # AN ENTRY POINT IDENTIFICATION IS ASSEMBLED (BL$XX).
7481: #
7482: # THE EXACT ENTRY CONDITIONS DEPEND ON THE MANNER IN
7483: # WHICH THE ROUTINE IS ACCESSED AND ARE DOCUMENTED WITH
7484: # THE INDIVIDUAL ROUTINES AS REQUIRED.
7485: #
7486: # THE ORDER OF THESE ROUTINES IS ALPHABETICAL WITH THE
7487: # FOLLOWING EXCEPTIONS.
7488: #
7489: # THE ROUTINES FOR SEBLK AND EXBLK ENTRIES OCCUR FIRST SO
7490: # THAT EXPRESSIONS CAN BE QUICKLY IDENTIFIED FROM THE FACT
7491: # THAT THEIR ROUTINES LIE BEFORE THE SYMBOL B$E$$.
7492: #
7493: # THESE ARE IMMEDIATELY FOLLOWED BY THE ROUTINE FOR A TRBLK
7494: # SO THAT THE TEST AGAINST THE SYMBOL B$T$$ CHECKS FOR
7495: # TRAPPED VALUES OR EXPRESSION VALUES (SEE PROCEDURE EVALP)
7496: #
7497: # THE PATTERN ROUTINES LIE AFTER THIS SECTION SO THAT
7498: # PATTERNS ARE IDENTIFIED WITH ROUTINES STARTING AT OR
7499: # AFTER THE INITIAL INSTRUCTION IN THESE ROUTINES (P$AAA).
7500: #
7501: # THE SYMBOL B$AAA DEFINES THE FIRST LOCATION FOR BLOCK
7502: # ROUTINES AND THE SYMBOL P$YYY (AT THE END OF THE PATTERN
7503: # MATCH ROUTINES SECTION) DEFINES THE LAST SUCH ENTRY POINT
7504: #
7505: .align 2
7506: .word bl$$i
7507: b$aaa: # entry point of first block routine
7508: #page
7509: #
7510: # EXBLK
7511: #
7512: # THE ROUTINE FOR AN EXBLK LOADS THE EXPRESSION ONTO
7513: # THE STACK AS A VALUE.
7514: #
7515: # (XR) POINTER TO EXBLK
7516: #
7517: .align 2
7518: .word bl$ex
7519: b$exl: # entry point (exblk)
7520: jmp exixr # stack xr and obey next code word
7521: #page
7522: #
7523: # SEBLK
7524: #
7525: # THE ROUTINE FOR SEBLK IS ACCESSED FROM THE GENERATED
7526: # CODE TO LOAD THE EXPRESSION VALUE ONTO THE STACK.
7527: #
7528: .align 2
7529: .word bl$se
7530: b$sel: # entry point (seblk)
7531: jmp exixr # stack xr and obey next code word
7532: #
7533: # DEFINE SYMBOL WHICH MARKS END OF ENTRIES FOR EXPRESSIONS
7534: #
7535: .align 2
7536: .word bl$$i
7537: b$e$$: # entry point
7538: #page
7539: #
7540: # TRBLK
7541: #
7542: # THE ROUTINE FOR A TRBLK IS NEVER EXECUTED
7543: #
7544: .align 2
7545: .word bl$tr
7546: b$trt: # entry point (trblk)
7547: #
7548: # DEFINE SYMBOL MARKING END OF TRAP AND EXPRESSION BLOCKS
7549: #
7550: .align 2
7551: .word bl$$i
7552: b$t$$: # end of trblk,seblk,exblk entries
7553: #page
7554: #
7555: # ARBLK
7556: #
7557: # THE ROUTINE FOR ARBLK IS NEVER EXECUTED
7558: #
7559: .align 2
7560: .word bl$ar
7561: b$art: # entry point (arblk)
7562: #page
7563: #
7564: # BCBLK
7565: #
7566: # THE ROUTINE FOR A BCBLK IS NEVER EXECUTED
7567: #
7568: # (XR) POINTER TO BCBLK
7569: #
7570: .align 2
7571: .word bl$bc
7572: b$bct: # entry point (bcblk)
7573: #page
7574: #
7575: # BFBLK
7576: #
7577: # THE ROUTINE FOR A BFBLK IS NEVER EXECUTED
7578: #
7579: # (XR) POINTER TO BFBLK
7580: #
7581: .align 2
7582: .word bl$bf
7583: b$bft: # entry point (bfblk)
7584: #page
7585: #
7586: # CCBLK
7587: #
7588: # THE ROUTINE FOR CCBLK IS NEVER ENTERED
7589: #
7590: .align 2
7591: .word bl$cc
7592: b$cct: # entry point (ccblk)
7593: #page
7594: #
7595: # CDBLK
7596: #
7597: # THE CDBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
7598: # THERE ARE TWO CASES DEPENDING ON THE FORM OF CDFAL.
7599: #
7600: # ENTRY FOR COMPLEX FAILURE CODE AT CDFAL
7601: #
7602: # (XR) POINTER TO CDBLK
7603: #
7604: .align 2
7605: .word bl$cd
7606: b$cdc: # entry point (cdblk)
7607: bcdc0: movl flptr,sp # pop garbage off stack
7608: movl 4*cdfal(r9),(sp)# set failure offset
7609: jmp stmgo # enter stmt
7610: #page
7611: #
7612: # CDBLK (CONTINUED)
7613: #
7614: # ENTRY FOR SIMPLE FAILURE CODE AT CDFAL
7615: #
7616: # (XR) POINTER TO CDBLK
7617: #
7618: .align 2
7619: .word bl$cd
7620: b$cds: # entry point (cdblk)
7621: bcds0: movl flptr,sp # pop garbage off stack
7622: movl $4*cdfal,(sp) # set failure offset
7623: jmp stmgo # enter stmt
7624: #page
7625: #
7626: # CMBLK
7627: #
7628: # THE ROUTINE FOR A CMBLK IS NEVER EXECUTED
7629: #
7630: .align 2
7631: .word bl$cm
7632: b$cmt: # entry point (cmblk)
7633: #page
7634: #
7635: # CTBLK
7636: #
7637: # THE ROUTINE FOR A CTBLK IS NEVER EXECUTED
7638: #
7639: .align 2
7640: .word bl$ct
7641: b$ctt: # entry point (ctblk)
7642: #page
7643: #
7644: # DFBLK
7645: #
7646: # THE ROUTINE FOR A DFBLK IS ACCESSED FROM THE O$FNC ENTRY
7647: # TO CALL A DATATYPE FUNCTION AND BUILD A PDBLK.
7648: #
7649: # (XL) POINTER TO DFBLK
7650: #
7651: .align 2
7652: .word bl$df
7653: b$dfc: # entry point
7654: movl 4*dfpdl(r10),r6 # load length of pdblk
7655: jsb alloc # allocate pdblk
7656: movl $b$pdt,(r9) # store type word
7657: movl r10,4*pddfp(r9) # store dfblk pointer
7658: movl r9,r8 # save pointer to pdblk
7659: addl2 r6,r9 # point past pdblk
7660: movl 4*fargs(r10),r6 # set to count fields
7661: #
7662: # LOOP TO ACQUIRE FIELD VALUES FROM STACK
7663: #
7664: bdfc1: movl (sp)+,-(r9) # move a field value
7665: sobgtr r6,bdfc1 # loop till all moved
7666: movl r8,r9 # recall pointer to pdblk
7667: jmp exsid # exit setting id field
7668: #page
7669: #
7670: # EFBLK
7671: #
7672: # THE ROUTINE FOR AN EFBLK IS PASSED CONTROL FORM THE O$FNC
7673: # ENTRY TO CALL AN EXTERNAL FUNCTION.
7674: #
7675: # (XL) POINTER TO EFBLK
7676: #
7677: .align 2
7678: .word bl$ef
7679: b$efc: # entry point (efblk)
7680: movl 4*fargs(r10),r8 # load number of arguments
7681: moval 0[r8],r8 # convert to offset
7682: movl r10,-(sp) # save pointer to efblk
7683: movl sp,r10 # copy pointer to arguments
7684: #
7685: # LOOP TO CONVERT ARGUMENTS
7686: #
7687: befc1: addl2 $4,r10 # point to next entry
7688: movl (sp),r9 # load pointer to efblk
7689: subl2 $4,r8 # decrement eftar offset
7690: addl2 r8,r9 # point to next eftar entry
7691: movl 4*eftar(r9),r9 # load eftar entry
7692: casel r9,$0,$4 # switch on type
7693: 5:
7694: .word befc7-5b # no conversion needed
7695: .word befc2-5b # string
7696: .word befc3-5b # integer
7697: .word befc4-5b # real
7698: #esw # end of switch on type
7699: #
7700: # HERE TO CONVERT TO STRING
7701: #
7702: befc2: movl (r10),-(sp) # stack arg ptr
7703: jsb gtstg # convert argument to string
7704: .long er_039 # external function argument is not string
7705: jmp befc6 # jump to merge
7706: #page
7707: #
7708: # EFBLK (CONTINUED)
7709: #
7710: # HERE TO CONVERT AN INTEGER
7711: #
7712: befc3: movl (r10),r9 # load next argument
7713: movl r8,befof # save offset
7714: jsb gtint # convert to integer
7715: .long er_040 # external function argument is not integer
7716: jmp befc5 # merge with real case
7717: #
7718: # HERE TO CONVERT A REAL
7719: #
7720: befc4: movl (r10),r9 # load next argument
7721: movl r8,befof # save offset
7722: jsb gtrea # convert to real
7723: .long er_265 # external function argument is not real
7724: #
7725: # INTEGER CASE MERGES HERE
7726: #
7727: befc5: movl befof,r8 # restore offset
7728: #
7729: # STRING MERGES HERE
7730: #
7731: befc6: movl r9,(r10) # store converted result
7732: #
7733: # NO CONVERSION MERGES HERE
7734: #
7735: befc7: tstl r8 # loop back if more to go
7736: bnequ befc1
7737: #
7738: # HERE AFTER CONVERTING ALL THE ARGUMENTS
7739: #
7740: movl (sp)+,r10 # restore efblk pointer
7741: movl 4*fargs(r10),r6 # get number of args
7742: jsb sysex # call routine to call external fnc
7743: .long exfal # fail if failure
7744: #page
7745: #
7746: # EFBLK (CONTINUED)
7747: #
7748: # RETURN HERE WITH RESULT IN XR
7749: #
7750: # FIRST DEFEND AGAINST NON-STANDARD NULL STRING RETURNED
7751: #
7752: movl 4*efrsl(r10),r7 # get result type id
7753: bnequ befa8 # branch if not unconverted
7754: cmpl (r9),$b$scl # jump if not a string
7755: bnequ befc8
7756: tstl 4*sclen(r9) # return null if null
7757: bnequ 0f
7758: jmp exnul
7759: 0:
7760: #
7761: # HERE IF CONVERTED RESULT TO CHECK FOR NULL STRING
7762: #
7763: befa8: cmpl r7,$num01 # jump if not a string
7764: bnequ befc8
7765: tstl 4*sclen(r9) # return null if null
7766: bnequ 0f
7767: jmp exnul
7768: 0:
7769: #
7770: # RETURN IF RESULT IS IN DYNAMIC STORAGE
7771: #
7772: befc8: cmpl r9,dnamb # jump if not in dynamic storage
7773: blssu befc9
7774: cmpl r9,dnamp # return result if already dynamic
7775: bgtru 0f
7776: jmp exixr
7777: 0:
7778: #
7779: # HERE WE COPY A RESULT INTO THE DYNAMIC REGION
7780: #
7781: befc9: movl (r9),r6 # get possible type word
7782: tstl r7 # jump if unconverted result
7783: beqlu bef11
7784: movl $b$scl,r6 # string
7785: cmpl r7,$num01 # yes jump
7786: beqlu bef10
7787: movl $b$icl,r6 # integer
7788: cmpl r7,$num02 # yes jump
7789: beqlu bef10
7790: movl $b$rcl,r6 # real
7791: #
7792: # STORE TYPE WORD IN RESULT
7793: #
7794: bef10: movl r6,(r9) # stored before copying to dynamic
7795: #
7796: # MERGE FOR UNCONVERTED RESULT
7797: #
7798: bef11: jsb blkln # get length of block
7799: movl r9,r10 # copy address of old block
7800: jsb alloc # allocate dynamic block same size
7801: movl r9,-(sp) # set pointer to new block as result
7802: jsb sbmvw # copy old block to dynamic block
7803: jmp exits # exit with result on stack
7804: #page
7805: #
7806: # EVBLK
7807: #
7808: # THE ROUTINE FOR AN EVBLK IS NEVER EXECUTED
7809: #
7810: .align 2
7811: .word bl$ev
7812: b$evt: # entry point (evblk)
7813: #page
7814: #
7815: # FFBLK
7816: #
7817: # THE ROUTINE FOR AN FFBLK IS EXECUTED FROM THE O$FNC ENTRY
7818: # TO CALL A FIELD FUNCTION AND EXTRACT A FIELD VALUE/NAME.
7819: #
7820: # (XL) POINTER TO FFBLK
7821: #
7822: .align 2
7823: .word bl$ff
7824: b$ffc: # entry point (ffblk)
7825: movl r10,r9 # copy ffblk pointer
7826: movl (r3)+,r8 # load next code word
7827: movl (sp),r10 # load pdblk pointer
7828: cmpl (r10),$b$pdt # jump if not pdblk at all
7829: bnequ bffc2
7830: movl 4*pddfp(r10),r6 # load dfblk pointer from pdblk
7831: #
7832: # LOOP TO FIND CORRECT FFBLK FOR THIS PDBLK
7833: #
7834: bffc1: cmpl r6,4*ffdfp(r9) # jump if this is the correct ffblk
7835: beqlu bffc3
7836: movl 4*ffnxt(r9),r9 # else link to next ffblk on chain
7837: bnequ bffc1 # loop back if another entry to check
7838: #
7839: # HERE FOR BAD ARGUMENT
7840: #
7841: bffc2: jmp er_041 # field function argument is wrong datatype
7842: #page
7843: #
7844: # FFBLK (CONTINUED)
7845: #
7846: # HERE AFTER LOCATING CORRECT FFBLK
7847: #
7848: bffc3: movl 4*ffofs(r9),r6 # load field offset
7849: cmpl r8,$ofne$ # jump if called by name
7850: beqlu bffc5
7851: addl2 r6,r10 # else point to value field
7852: movl (r10),r9 # load value
7853: cmpl (r9),$b$trt # jump if not trapped
7854: bnequ bffc4
7855: subl2 r6,r10 # else restore name base,offset
7856: movl r8,(sp) # save next code word over pdblk ptr
7857: jsb acess # access value
7858: .long exfal # fail if access fails
7859: movl (sp),r8 # restore next code word
7860: #
7861: # HERE AFTER GETTING VALUE IN (XR)
7862: #
7863: bffc4: movl r9,(sp) # store value on stack (over pdblk)
7864: movl r8,r9 # copy next code word
7865: movl (r9),r10 # load entry address
7866: movl r10,r11 # jump to routine for next code word
7867: jmp (r11)
7868: #
7869: # HERE IF CALLED BY NAME
7870: #
7871: bffc5: movl r6,-(sp) # store name offset (base is set)
7872: jmp exits # exit with name on stack
7873: #page
7874: #
7875: # ICBLK
7876: #
7877: # THE ROUTINE FOR ICBLK IS EXECUTED FROM THE GENERATED
7878: # CODE TO LOAD AN INTEGER VALUE ONTO THE STACK.
7879: #
7880: # (XR) POINTER TO ICBLK
7881: #
7882: .align 2
7883: .word bl$ic
7884: b$icl: # entry point (icblk)
7885: jmp exixr # stack xr and obey next code word
7886: #page
7887: #
7888: # KVBLK
7889: #
7890: # THE ROUTINE FOR A KVBLK IS NEVER EXECUTED.
7891: #
7892: .align 2
7893: .word bl$kv
7894: b$kvt: # entry point (kvblk)
7895: #page
7896: #
7897: # NMBLK
7898: #
7899: # THE ROUTINE FOR A NMBLK IS EXECUTED FROM THE GENERATED
7900: # CODE FOR THE CASE OF LOADING A NAME ONTO THE STACK
7901: # WHERE THE NAME IS THAT OF A NATURAL VARIABLE WHICH CAN
7902: # BE PREEVALUATED AT COMPILE TIME.
7903: #
7904: # (XR) POINTER TO NMBLK
7905: #
7906: .align 2
7907: .word bl$nm
7908: b$nml: # entry point (nmblk)
7909: jmp exixr # stack xr and obey next code word
7910: #page
7911: #
7912: # PDBLK
7913: #
7914: # THE ROUTINE FOR A PDBLK IS NEVER EXECUTED
7915: #
7916: .align 2
7917: .word bl$pd
7918: b$pdt: # entry point (pdblk)
7919: #page
7920: #
7921: # PFBLK
7922: #
7923: # THE ROUTINE FOR A PFBLK IS EXECUTED FROM THE ENTRY O$FNC
7924: # TO CALL A PROGRAM DEFINED FUNCTION.
7925: #
7926: # (XL) POINTER TO PFBLK
7927: #
7928: # THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING
7929: # CONTROL TO THE PROGRAM DEFINED FUNCTION.
7930: #
7931: # SAVED VALUE OF FIRST ARGUMENT
7932: # .
7933: # SAVED VALUE OF LAST ARGUMENT
7934: # SAVED VALUE OF FIRST LOCAL
7935: # .
7936: # SAVED VALUE OF LAST LOCAL
7937: # SAVED VALUE OF FUNCTION NAME
7938: # SAVED CODE BLOCK PTR (R$COD)
7939: # SAVED CODE POINTER (-R$COD)
7940: # SAVED VALUE OF FLPRT
7941: # SAVED VALUE OF FLPTR
7942: # POINTER TO PFBLK
7943: # FLPTR --------------- ZERO (TO BE OVERWRITTEN WITH OFFS)
7944: #
7945: .align 2
7946: .word bl$pf
7947: b$pfc: # entry point (pfblk)
7948: movl r10,bpfpf # save pfblk ptr (need not be reloc)
7949: movl r10,r9 # copy for the moment
7950: movl 4*pfvbl(r9),r10 # point to vrblk for function
7951: #
7952: # LOOP TO FIND OLD VALUE OF FUNCTION
7953: #
7954: bpf01: movl r10,r7 # save pointer
7955: movl 4*vrval(r10),r10# load value
7956: cmpl (r10),$b$trt # loop if trblk
7957: beqlu bpf01
7958: #
7959: # SET VALUE TO NULL AND SAVE OLD FUNCTION VALUE
7960: #
7961: movl r10,bpfsv # save old value
7962: movl r7,r10 # point back to block with value
7963: movl $nulls,4*vrval(r10) # set value to null
7964: movl 4*fargs(r9),r6 # load number of arguments
7965: addl2 $4*pfarg,r9 # point to pfarg entries
7966: tstl r6 # jump if no arguments
7967: beqlu bpf04
7968: movl sp,r10 # ptr to last arg
7969: moval 0[r6],r6 # convert no. of args to bytes offset
7970: addl2 r6,r10 # point before first arg
7971: movl r10,bpfxt # remember arg pointer
7972: #page
7973: #
7974: # PFBLK (CONTINUED)
7975: #
7976: # LOOP TO SAVE OLD ARGUMENT VALUES AND SET NEW ONES
7977: #
7978: bpf02: movl (r9)+,r10 # load vrblk ptr for next argument
7979: #
7980: # LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
7981: #
7982: bpf03: movl r10,r8 # save pointer
7983: movl 4*vrval(r10),r10# load next value
7984: cmpl (r10),$b$trt # loop back if trblk
7985: beqlu bpf03
7986: #
7987: # SAVE OLD VALUE AND GET NEW VALUE
7988: #
7989: movl r10,r6 # keep old value
7990: movl bpfxt,r10 # point before next stacked arg
7991: movl -(r10),r7 # load argument (new value)
7992: movl r6,(r10) # save old value
7993: movl r10,bpfxt # keep arg ptr for next time
7994: movl r8,r10 # point back to block with value
7995: movl r7,4*vrval(r10) # set new value
7996: cmpl sp,bpfxt # loop if not all done
7997: bnequ bpf02
7998: #
7999: # NOW PROCESS LOCALS
8000: #
8001: bpf04: movl bpfpf,r10 # restore pfblk pointer
8002: movl 4*pfnlo(r10),r6 # load number of locals
8003: beqlu bpf07 # jump if no locals
8004: movl $nulls,r7 # get null constant
8005: # set local counter
8006: #
8007: # LOOP TO PROCESS LOCALS
8008: #
8009: bpf05: movl (r9)+,r10 # load vrblk ptr for next local
8010: #
8011: # LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
8012: #
8013: bpf06: movl r10,r8 # save pointer
8014: movl 4*vrval(r10),r10# load next value
8015: cmpl (r10),$b$trt # loop back if trblk
8016: beqlu bpf06
8017: #
8018: # SAVE OLD VALUE AND SET NULL AS NEW VALUE
8019: #
8020: movl r10,-(sp) # stack old value
8021: movl r8,r10 # point back to block with value
8022: movl r7,4*vrval(r10) # set null as new value
8023: sobgtr r6,bpf05 # loop till all locals processed
8024: #page
8025: #
8026: # PFBLK (CONTINUED)
8027: #
8028: # HERE AFTER PROCESSING ARGUMENTS AND LOCALS
8029: #
8030: bpf07: clrl r9 # zero reg xr in case
8031: tstl kvpfl # skip if profiling is off
8032: beqlu bpf7c
8033: cmpl kvpfl,$num02 # branch on type of profile
8034: beqlu bpf7a
8035: #
8036: # HERE IF &PROFILE = 1
8037: #
8038: jsb systm # get current time
8039: movl r5,pfetm # save for a sec
8040: subl2 pfstm,r5 # find time used by caller
8041: jsb icbld # build into an icblk
8042: movl pfetm,r5 # reload current time
8043: jmp bpf7b # merge
8044: #
8045: # HERE IF &PROFILE = 2
8046: #
8047: bpf7a: movl pfstm,r5 # get start time of calling stmt
8048: jsb icbld # assemble an icblk round it
8049: jsb systm # get now time
8050: #
8051: # BOTH TYPES OF PROFILE MERGE HERE
8052: #
8053: bpf7b: movl r5,pfstm # set start time of 1st func stmt
8054: movl sp,pffnc # flag function entry
8055: #
8056: # NO PROFILING MERGES HERE
8057: #
8058: bpf7c: movl r9,-(sp) # stack icblk ptr (or zero)
8059: movl r$cod,r6 # load old code block pointer
8060: movl r3,r7 # get code pointer
8061: subl2 r6,r7 # make code pointer into offset
8062: movl bpfpf,r10 # recall pfblk pointer
8063: movl bpfsv,-(sp) # stack old value of function name
8064: movl r6,-(sp) # stack code block pointer
8065: movl r7,-(sp) # stack code offset
8066: movl flprt,-(sp) # stack old flprt
8067: movl flptr,-(sp) # stack old failure pointer
8068: movl r10,-(sp) # stack pointer to pfblk
8069: clrl -(sp) # dummy zero entry for fail return
8070: jsb sbchk # check for stack overflow
8071: movl sp,flptr # set new fail return value
8072: movl sp,flprt # set new flprt
8073: movl kvtra,r6 # load trace value
8074: addl2 kvftr,r6 # add ftrace value
8075: bnequ bpf09 # jump if tracing possible
8076: incl kvfnc # else bump fnclevel
8077: #
8078: # HERE TO ACTUALLY JUMP TO FUNCTION
8079: #
8080: bpf08: movl 4*pfcod(r10),r9 # point to code
8081: movl (r9),r11 # off to execute function
8082: jmp (r11)
8083: #
8084: # HERE IF TRACING IS POSSIBLE
8085: #
8086: bpf09: movl 4*pfctr(r10),r9 # load possible call trace trblk
8087: movl 4*pfvbl(r10),r10# load vrblk pointer for function
8088: movl $4*vrval,r6 # set name offset for variable
8089: tstl kvtra # jump if trace mode is off
8090: beqlu bpf10
8091: tstl r9 # or if there is no call trace
8092: beqlu bpf10
8093: #
8094: # HERE IF CALL TRACED
8095: #
8096: decl kvtra # decrement trace count
8097: tstl 4*trfnc(r9) # jump if print trace
8098: beqlu bpf11
8099: jsb trxeq # execute function type trace
8100: #page
8101: #
8102: # PFBLK (CONTINUED)
8103: #
8104: # HERE TO TEST FOR FTRACE TRACE
8105: #
8106: bpf10: tstl kvftr # jump if ftrace is off
8107: beqlu bpf16
8108: decl kvftr # else decrement ftrace
8109: #
8110: # HERE FOR PRINT TRACE
8111: #
8112: bpf11: jsb prtsn # print statement number
8113: jsb prtnm # print function name
8114: movl $ch$pp,r6 # load left paren
8115: jsb prtch # print left paren
8116: movl 4*1(sp),r10 # recover pfblk pointer
8117: tstl 4*fargs(r10) # skip if no arguments
8118: beqlu bpf15
8119: clrl r7 # else set argument counter
8120: jmp bpf13 # jump into loop
8121: #
8122: # LOOP TO PRINT ARGUMENT VALUES
8123: #
8124: bpf12: movl $ch$cm,r6 # load comma
8125: jsb prtch # print to separate from last arg
8126: #
8127: # MERGE HERE FIRST TIME (NO COMMA REQUIRED)
8128: #
8129: bpf13: movl r7,(sp) # save arg ctr (over failoffs is ok)
8130: moval 0[r7],r7 # convert to byte offset
8131: addl2 r7,r10 # point to next argument pointer
8132: movl 4*pfarg(r10),r9 # load next argument vrblk ptr
8133: subl2 r7,r10 # restore pfblk pointer
8134: movl 4*vrval(r9),r9 # load next value
8135: jsb prtvl # print argument value
8136: #page
8137: #
8138: # HERE AFTER DEALING WITH ONE ARGUMENT
8139: #
8140: movl (sp),r7 # restore argument counter
8141: incl r7 # increment argument counter
8142: cmpl r7,4*fargs(r10) # loop if more to print
8143: blssu bpf12
8144: #
8145: # MERGE HERE IN NO ARGS CASE TO PRINT PAREN
8146: #
8147: bpf15: movl $ch$rp,r6 # load right paren
8148: jsb prtch # print to terminate output
8149: jsb prtnl # terminate print line
8150: #
8151: # MERGE HERE TO EXIT WITH TEST FOR FNCLEVEL TRACE
8152: #
8153: bpf16: incl kvfnc # increment fnclevel
8154: movl r$fnc,r10 # load ptr to possible trblk
8155: jsb ktrex # call keyword trace routine
8156: #
8157: # CALL FUNCTION AFTER TRACE TESTS COMPLETE
8158: #
8159: movl 4*1(sp),r10 # restore pfblk pointer
8160: jmp bpf08 # jump back to execute function
8161: #page
8162: #
8163: # RCBLK
8164: #
8165: # THE ROUTINE FOR AN RCBLK IS EXECUTED FROM THE GENERATED
8166: # CODE TO LOAD A REAL VALUE ONTO THE STACK.
8167: #
8168: # (XR) POINTER TO RCBLK
8169: #
8170: .align 2
8171: .word bl$rc
8172: b$rcl: # entry point (rcblk)
8173: jmp exixr # stack xr and obey next code word
8174: #page
8175: #
8176: # SCBLK
8177: #
8178: # THE ROUTINE FOR AN SCBLK IS EXECUTED FROM THE GENERATED
8179: # CODE TO LOAD A STRING VALUE ONTO THE STACK.
8180: #
8181: # (XR) POINTER TO SCBLK
8182: #
8183: .align 2
8184: .word bl$sc
8185: b$scl: # entry point (scblk)
8186: jmp exixr # stack xr and obey next code word
8187: #page
8188: #
8189: # TBBLK
8190: #
8191: # THE ROUTINE FOR A TBBLK IS NEVER EXECUTED
8192: #
8193: .align 2
8194: .word bl$tb
8195: b$tbt: # entry point (tbblk)
8196: #page
8197: #
8198: # TEBLK
8199: #
8200: # THE ROUTINE FOR A TEBLK IS NEVER EXECUTED
8201: #
8202: .align 2
8203: .word bl$te
8204: b$tet: # entry point (teblk)
8205: #page
8206: #
8207: # VCBLK
8208: #
8209: # THE ROUTINE FOR A VCBLK IS NEVER EXECUTED
8210: #
8211: .align 2
8212: .word bl$vc
8213: b$vct: # entry point (vcblk)
8214: #page
8215: #
8216: # VRBLK
8217: #
8218: # THE VRBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
8219: # THERE ARE SIX ENTRIES FOR VRBLK COVERING VARIOUS CASES
8220: #
8221: .align 2
8222: .word bl$$i
8223: b$vr$: # mark start of vrblk entry points
8224: #
8225: # ENTRY FOR VRGET (TRAPPED CASE). THIS ROUTINE IS CALLED
8226: # FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE.
8227: # THIS ENTRY POINT IS USED IF AN ACCESS TRACE OR INPUT
8228: # ASSOCIATION IS CURRENTLY ACTIVE.
8229: #
8230: # (XR) POINTER TO VRGET FIELD OF VRBLK
8231: #
8232: .align 2
8233: .word bl$$i
8234: b$vra: # entry point
8235: movl r9,r10 # copy name base (vrget = 0)
8236: movl $4*vrval,r6 # set name offset
8237: jsb acess # access value
8238: .long exfal # fail if access fails
8239: jmp exixr # else exit with result in xr
8240: #page
8241: #
8242: # VRBLK (CONTINUED)
8243: #
8244: # ENTRY FOR VRSTO (ERROR CASE. THIS ROUTINE IS CALLED FROM
8245: # THE EXECUTED CODE FOR AN ATTEMPT TO MODIFY THE VALUE
8246: # OF A PROTECTED (PATTERN VALUED) NATURAL VARIABLE.
8247: #
8248: b$vre: # entry point
8249: jmp er_042 # attempt to change value of protected variable
8250: #page
8251: #
8252: # VRBLK (CONTINUED)
8253: #
8254: # ENTRY FOR VRTRA (UNTRAPPED CASE). THIS ROUTINE IS CALLED
8255: # FROM THE EXECUTED CODE TO TRANSFER TO A LABEL.
8256: #
8257: # (XR) POINTER TO VRTRA FIELD OF VRBLK
8258: #
8259: b$vrg: # entry point
8260: movl 4*vrlbo(r9),r9 # load code pointer
8261: movl (r9),r10 # load entry address
8262: movl r10,r11 # jump to routine for next code word
8263: jmp (r11)
8264: #page
8265: #
8266: # VRBLK (CONTINUED)
8267: #
8268: # ENTRY FOR VRGET (UNTRAPPED CASE). THIS ROUTINE IS CALLED
8269: # FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE.
8270: #
8271: # (XR) POINTS TO VRGET FIELD OF VRBLK
8272: #
8273: b$vrl: # entry point
8274: movl 4*vrval(r9),-(sp)# load value onto stack (vrget = 0)
8275: jmp exits # obey next code word
8276: #page
8277: #
8278: # VRBLK (CONTINUED)
8279: #
8280: # ENTRY FOR VRSTO (UNTRAPPED CASE). THIS ROUTINE IS CALLED
8281: # FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE.
8282: #
8283: # (XR) POINTER TO VRSTO FIELD OF VRBLK
8284: #
8285: b$vrs: # entry point
8286: movl (sp),4*vrvlo(r9)# store value, leave on stack
8287: jmp exits # obey next code word
8288: #page
8289: #
8290: # VRBLK (CONTINUED)
8291: #
8292: # VRTRA (TRAPPED CASE). THIS ROUTINE IS CALLED FROM THE
8293: # GENERATED CODE TO TRANSFER TO A LABEL WHEN A LABEL
8294: # TRACE IS CURRENTLY ACTIVE.
8295: #
8296: b$vrt: # entry point
8297: subl2 $4*vrtra,r9 # point back to start of vrblk
8298: movl r9,r10 # copy vrblk pointer
8299: movl $4*vrval,r6 # set name offset
8300: movl 4*vrlbl(r10),r9 # load pointer to trblk
8301: tstl kvtra # jump if trace is off
8302: beqlu bvrt2
8303: decl kvtra # else decrement trace count
8304: tstl 4*trfnc(r9) # jump if print trace case
8305: beqlu bvrt1
8306: jsb trxeq # else execute full trace
8307: jmp bvrt2 # merge to jump to label
8308: #
8309: # HERE FOR PRINT TRACE -- PRINT COLON ( LABEL NAME )
8310: #
8311: bvrt1: jsb prtsn # print statement number
8312: movl r10,r9 # copy vrblk pointer
8313: movl $ch$cl,r6 # colon
8314: jsb prtch # print it
8315: movl $ch$pp,r6 # left paren
8316: jsb prtch # print it
8317: jsb prtvn # print label name
8318: movl $ch$rp,r6 # right paren
8319: jsb prtch # print it
8320: jsb prtnl # terminate line
8321: movl 4*vrlbl(r10),r9 # point back to trblk
8322: #
8323: # MERGE HERE TO JUMP TO LABEL
8324: #
8325: bvrt2: movl 4*trlbl(r9),r9 # load pointer to actual code
8326: movl (r9),r11 # execute statement at label
8327: jmp (r11)
8328: #page
8329: #
8330: # VRBLK (CONTINUED)
8331: #
8332: # ENTRY FOR VRSTO (TRAPPED CASE). THIS ROUTINE IS CALLED
8333: # FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE.
8334: # THIS ENTRY IS USED WHEN A VALUE TRACE OR OUTPUT
8335: # ASSOCIATION IS CURRENTLY ACTIVE.
8336: #
8337: # (XR) POINTER TO VRSTO FIELD OF VRBLK
8338: #
8339: b$vrv: # entry point
8340: movl (sp),r7 # load value (leave copy on stack)
8341: subl2 $4*vrsto,r9 # point to vrblk
8342: movl r9,r10 # copy vrblk pointer
8343: movl $4*vrval,r6 # set offset
8344: jsb asign # call assignment routine
8345: .long exfal # fail if assignment fails
8346: jmp exits # else return with result on stack
8347: #page
8348: #
8349: # XNBLK
8350: #
8351: # THE ROUTINE FOR AN XNBLK IS NEVER EXECUTED
8352: #
8353: .align 2
8354: .word bl$xn
8355: b$xnt: # entry point (xnblk)
8356: #page
8357: #
8358: # XRBLK
8359: #
8360: # THE ROUTINE FOR AN XRBLK IS NEVER EXECUTED
8361: #
8362: .align 2
8363: .word bl$xr
8364: b$xrt: # entry point (xrblk)
8365: #
8366: # MARK ENTRY ADDRESS PAST LAST BLOCK ACTION ROUTINE
8367: #
8368: .align 2
8369: .word bl$$i
8370: b$yyy: # last block routine entry point
8371: #title s p i t b o l -- pattern matching routines
8372: #
8373: # THE FOLLOWING SECTION CONSISTS OF THE PATTERN MATCHING
8374: # ROUTINES. ALL PATTERN NODES CONTAIN A POINTER (PCODE)
8375: # TO ONE OF THE ROUTINES IN THIS SECTION (P$XXX).
8376: #
8377: # NOTE THAT THIS SECTION FOLLOWS THE B$XXX ROUTINES TO
8378: # ENABLE A FAST TEST FOR THE PATTERN DATATYPE.
8379: #
8380: .align 2
8381: .word bl$$i
8382: p$aaa: # entry to mark first pattern
8383: #
8384: #
8385: # THE ENTRY CONDITIONS TO THE MATCH ROUTINE ARE AS FOLLOWS
8386: # (SEE O$PMN, O$PMV, O$PMS AND PROCEDURE MATCH).
8387: #
8388: # STACK CONTENTS.
8389: #
8390: # NAME BASE (O$PMN ONLY)
8391: # NAME OFFSET (O$PMN ONLY)
8392: # TYPE (0-O$PMN, 1-O$PMV, 2-O$PMS)
8393: # PMHBS --------------- INITIAL CURSOR (ZERO)
8394: # INITIAL NODE POINTER
8395: # XS ------------------ =NDABO (ANCHORED), =NDUNA (UNANCH)
8396: #
8397: # REGISTER VALUES.
8398: #
8399: # (XS) SET AS SHOWN IN STACK DIAGRAM
8400: # (XR) POINTER TO INITIAL PATTERN NODE
8401: # (WB) INITIAL CURSOR (ZERO)
8402: #
8403: # GLOBAL PATTERN VALUES
8404: #
8405: # R$PMS POINTER TO SUBJECT STRING SCBLK
8406: # PMSSL LENGTH OF SUBJECT STRING IN CHARS
8407: # PMDFL DOT FLAG, INITIALLY ZERO
8408: # PMHBS SET AS SHOWN IN STACK DIAGRAM
8409: #
8410: # CONTROL IS PASSED BY BRANCHING THROUGH THE PCODE
8411: # FIELD OF THE INITIAL PATTERN NODE (BRI (XR)).
8412: #page
8413: #
8414: # DESCRIPTION OF ALGORITHM
8415: #
8416: # A PATTERN STRUCTURE IS REPRESENTED AS A LINKED GRAPH
8417: # OF NODES WITH THE FOLLOWING STRUCTURE.
8418: #
8419: # +------------------------------------+
8420: # I PCODE I
8421: # +------------------------------------+
8422: # I PTHEN I
8423: # +------------------------------------+
8424: # I PARM1 I
8425: # +------------------------------------+
8426: # I PARM2 I
8427: # +------------------------------------+
8428: #
8429: # PCODE IS A POINTER TO THE ROUTINE WHICH WILL PERFORM
8430: # THE MATCH OF THIS PARTICULAR NODE TYPE.
8431: #
8432: # PTHEN IS A POINTER TO THE SUCCESSOR NODE. I.E. THE NODE
8433: # TO BE MATCHED IF THE ATTEMPT TO MATCH THIS NODE SUCCEEDS.
8434: # IF THIS IS THE LAST NODE OF THE PATTERN PTHEN POINTS
8435: # TO THE DUMMY NODE NDNTH WHICH INITIATES PATTERN EXIT.
8436: #
8437: # PARM1, PARM2 ARE PARAMETERS WHOSE USE VARIES WITH THE
8438: # PARTICULAR NODE. THEY ARE ONLY PRESENT IF REQUIRED.
8439: #
8440: # ALTERNATIVES ARE HANDLED WITH THE SPECIAL ALTERNATIVE
8441: # NODE WHOSE PARAMETER POINTS TO THE NODE TO BE MATCHED
8442: # IF THERE IS A FAILURE ON THE SUCCESSOR PATH.
8443: #
8444: # THE FOLLOWING EXAMPLE ILLUSTRATES THE MANNER IN WHICH
8445: # THE STRUCTURE IS BUILT UP. THE PATTERN IS
8446: #
8447: # (A / B / C) (D / E) WHERE / IS ALTERNATION
8448: #
8449: # IN THE DIAGRAM, THE NODE MARKED + REPRESENTS AN
8450: # ALTERNATIVE NODE AND THE DOTTED LINE FROM A + NODE
8451: # REPRESENTS THE PARAMETER POINTER TO THE ALTERNATIVE.
8452: #
8453: # +---+ +---+ +---+ +---+
8454: # I + I-----I A I-----I + I-----I D I-----
8455: # +---+ +---+ I +---+ +---+
8456: # . I .
8457: # . I .
8458: # +---+ +---+ I +---+
8459: # I + I-----I B I--I I E I-----
8460: # +---+ +---+ I +---+
8461: # . I
8462: # . I
8463: # +---+ I
8464: # I C I------------I
8465: # +---+
8466: #page
8467: #
8468: # DURING THE MATCH, THE REGISTERS ARE USED AS FOLLOWS.
8469: #
8470: # (XR) POINTS TO THE CURRENT NODE
8471: # (XL) SCRATCH
8472: # (XS) MAIN STACK POINTER
8473: # (WB) CURSOR (NUMBER OF CHARS MATCHED)
8474: # (WA,WC) SCRATCH
8475: #
8476: # TO KEEP TRACK OF ALTERNATIVES, THE MAIN STACK IS USED AS
8477: # A HISTORY STACK AND CONTAINS TWO WORD ENTRIES.
8478: #
8479: # WORD 1 SAVED CURSOR VALUE
8480: # WORD 2 NODE TO MATCH ON FAILURE
8481: #
8482: # WHEN A FAILURE OCCURS, THE MOST RECENT ENTRY ON THIS
8483: # STACK IS POPPED OFF TO RESTORE THE CURSOR AND POINT
8484: # TO THE NODE TO BE MATCHED AS AN ALTERNATIVE. THE ENTRY
8485: # AT THE BOTTOM OF THE STACK POINTS TO THE FOLLOWING
8486: # SPECIAL NODES DEPENDING ON THE SCAN MODE.
8487: #
8488: # ANCHORED MODE THE BOTTOM ENTRY POINTS TO THE
8489: # SPECIAL NODE NDABO WHICH CAUSES AN
8490: # ABORT. THE CURSOR VALUE STORED
8491: # WITH THIS ENTRY IS ALWAYS ZERO.
8492: #
8493: # UNANCHORED MODE THE BOTTOM ENTRY POINTS TO THE
8494: # SPECIAL NODE NDUNA WHICH MOVES THE
8495: # ANCHOR POINT AND RESTARTS THE MATCH
8496: # THE CURSOR SAVED WITH THIS ENTRY
8497: # IS THE NUMBER OF CHARACTERS WHICH
8498: # LIE BEFORE THE INITIAL ANCHOR POINT
8499: # (I.E. THE NUMBER OF ANCHOR MOVES).
8500: # THIS ENTRY IS THREE WORDS LONG AND
8501: # ALSO CONTAINS THE INITIAL PATTERN.
8502: #
8503: # ENTRIES ARE MADE ON THIS HISTORY STACK BY ALTERNATIVE
8504: # NODES AND BY SOME SPECIAL COMPOUD PATTERNS AS DESCRIBED
8505: # LATER ON. THE FOLLOWING GLOBAL LOCATIONS ARE USED DURING
8506: # PATTERN MATCHING.
8507: #
8508: # R$PMS POINTER TO SUBJECT STRING
8509: # PMSSL LENGTH OF SUBJECT STRING
8510: # PMDFL FLAG SET NON-ZERO FOR DOT PATTERNS
8511: # PMHBS BASE PTR FOR CURRENT HISTORY STACK
8512: #
8513: # THE FOLLOWING EXIT POINTS ARE AVAILABLE TO MATCH ROUTINES
8514: #
8515: # SUCCP SUCCESS IN MATCHING CURRENT NODE
8516: # FAILP FAILURE IN MATCHING CURRENT NODE
8517: #page
8518: #
8519: # COMPOUND PATTERNS
8520: #
8521: # SOME PATTERNS HAVE IMPLICIT ALTERNATIVES AND THEIR
8522: # REPRESENTATION IN THE PATTERN STRUCTURE CONSISTS OF A
8523: # LINKED SET OF NODES AS INDICATED BY THESE DIAGRAMS.
8524: #
8525: # AS BEFORE, THE + REPRESENTS AN ALTERNATIVE NODE AND
8526: # THE DOTTED LINE FROM A + NODE IS THE PARAMETER POINTER
8527: # TO THE ALTERNATIVE PATTERN.
8528: #
8529: # ARB
8530: # ---
8531: #
8532: # +---+ THIS NODE (P$ARB) MATCHES NULL
8533: # I B I----- AND STACKS CURSOR, SUCCESSOR PTR,
8534: # +---+ CURSOR (COPY) AND A PTR TO NDARC.
8535: #
8536: #
8537: #
8538: #
8539: # BAL
8540: # ---
8541: #
8542: # +---+ THE P$BAL NODE SCANS A BALANCED
8543: # I B I----- STRING AND THEN STACKS A POINTER
8544: # +---+ TO ITSELF ON THE HISTORY STACK.
8545: #page
8546: #
8547: # COMPOUND PATTERN STRUCTURES (CONTINUED)
8548: #
8549: #
8550: # ARBNO
8551: # -----
8552: #
8553: # +---+ THIS ALTERNATIVE NODE MATCHES NULL
8554: # +----I + I----- THE FIRST TIME AND STACKS A POINTER
8555: # I +---+ TO THE ARGUMENT PATTERN X.
8556: # I .
8557: # I .
8558: # I +---+ NODE (P$ABA) TO STACK CURSOR
8559: # I I A I AND HISTORY STACK BASE PTR.
8560: # I +---+
8561: # I I
8562: # I I
8563: # I +---+ THIS IS THE ARGUMENT PATTERN. AS
8564: # I I X I INDICATED, THE SUCCESSOR OF THE
8565: # I +---+ PATTERN IS THE P$ABC NODE
8566: # I I
8567: # I I
8568: # I +---+ THIS NODE (P$ABC) POPS PMHBS,
8569: # +----I C I STACKS OLD PMHBS AND PTR TO NDABD
8570: # +---+ (UNLESS OPTIMISATION HAS OCCURRED)
8571: #
8572: # STRUCTURE AND EXECUTION OF THIS PATTERN RESEMBLE THOSE OF
8573: # RECURSIVE PATTERN MATCHING AND IMMEDIATE ASSIGNMENT.
8574: # THE ALTERNATIVE NODE AT THE HEAD OF THE STRUCTURE MATCHES
8575: # NULL INITIALLY BUT ON SUBSEQUENT FAILURE ENSURES ATTEMPT
8576: # TO MATCH THE ARGUMENT. BEFORE THE ARGUMENT IS MATCHED
8577: # P$ABA STACKS THE CURSOR,PMHBS AND A PTR TO P$ABB. IF
8578: # THE ARGUMENT CANT BE MATCHED , P$ABB REMOVES THIS SPECIAL
8579: # STACK ENTRY AND FAILS.
8580: # IF ARGUMENT IS MATCHED , P$ABC RESTORES THE OUTER PMHBS
8581: # VALUE (SAVED BY P$ABA) . THEN IF THE ARGUMENT HAS LEFT
8582: # ALTERNATIVES ON STACK IT STACKS THE INNER VALUE OF PMHBS
8583: # AND A PTR TO NDABD. IF ARGUMENT LEFT NOTHING ON THE STACK
8584: # IT OPTIMISES BY REMOVING ITEMS STACKED BY P$ABA. FINALLY
8585: # A CHECK IS MADE THAT ARGUMENT MATCHED MORE THAN THE NULL
8586: # STRING (CHECK IS INTENDED TO PREVENT USELESS LOOPING).
8587: # IF SO THE SUCCESSOR IS AGAIN THE ALTERNATIVE NODE AT THE
8588: # HEAD OF THE STRUCTURE , ENSURING A POSSIBLE EXTRA ATTEMPT
8589: # TO MATCH THE ARG IF NECESSARY. IF NOT , THE SUCCESSOR TO
8590: # ALTERNATIVE IS TAKEN SO AS TO TERMINATE THE LOOP. P$ABD
8591: # RESTORES INNER PMHBS PTR AND FAILS , THUS TRYING TO MATCH
8592: # ALTERNATIVES LEFT BY THE ARBNO ARGUMENT.
8593: #page
8594: #
8595: # COMPOUND PATTERN STRUCTURES (CONTINUED)
8596: #
8597: # BREAKX
8598: # ------
8599: #
8600: # +---+ THIS NODE IS A BREAK NODE FOR
8601: # +----I B I THE ARGUMENT TO BREAKX, IDENTICAL
8602: # I +---+ TO AN ORDINARY BREAK NODE.
8603: # I I
8604: # I I
8605: # I +---+ THIS ALTERNATIVE NODE STACKS A
8606: # I I + I----- POINTER TO THE BREAKX NODE TO
8607: # I +---+ ALLOW FOR SUBSEQUENT FAILURE
8608: # I .
8609: # I .
8610: # I +---+ THIS IS THE BREAKX NODE ITSELF. IT
8611: # +----I X I MATCHES ONE CHARACTER AND THEN
8612: # +---+ PROCEEDS BACK TO THE BREAK NODE.
8613: #
8614: #
8615: #
8616: #
8617: # FENCE
8618: # -----
8619: #
8620: # +---+ THE FENCE NODE MATCHES NULL AND
8621: # I F I----- STACKS A POINTER TO NODE NDABO TO
8622: # +---+ ABORT ON A SUBSEQUENT REMATCH
8623: #
8624: #
8625: #
8626: #
8627: # SUCCEED
8628: # -------
8629: #
8630: # +---+ THE NODE FOR SUCCEED MATCHES NULL
8631: # I S I----- AND STACKS A POINTER TO ITSELF
8632: # +---+ TO REPEAT THE MATCH ON A FAILURE.
8633: #page
8634: #
8635: # COMPOUND PATTERNS (CONTINUED)
8636: #
8637: # BINARY DOT (PATTERN ASSIGNMENT)
8638: # -------------------------------
8639: #
8640: # +---+ THIS NODE (P$PAA) SAVES THE CURRENT
8641: # I A I CURSOR AND A POINTER TO THE
8642: # +---+ SPECIAL NODE NDPAB ON THE STACK.
8643: # I
8644: # I
8645: # +---+ THIS IS THE STRUCTURE FOR THE
8646: # I X I PATTERN LEFT ARGUMENT OF THE
8647: # +---+ PATTERN ASSIGNMENT CALL.
8648: # I
8649: # I
8650: # +---+ THIS NODE (P$PAC) SAVES THE CURSOR,
8651: # I C I----- A PTR TO ITSELF, THE CURSOR (COPY)
8652: # +---+ AND A PTR TO NDPAD ON THE STACK.
8653: #
8654: #
8655: # THE FUNCTION OF THE MATCH ROUTINE FOR NDPAB (P$PAB)
8656: # IS SIMPLY TO UNSTACK ITSELF AND FAIL BACK ONTO THE STACK.
8657: #
8658: # THE MATCH ROUTINE FOR P$PAC ALSO SETS THE GLOBAL PATTERN
8659: # FLAG PMDFL NON-ZERO TO INDICATE THAT PATTERN ASSIGNMENTS
8660: # MAY HAVE OCCURED IN THE PATTERN MATCH
8661: #
8662: # IF PMDFL IS SET AT THE END OF THE MATCH (SEE P$NTH), THE
8663: # HISTORY STACK IS SCANNED FOR MATCHING NDPAB-NDPAD PAIRS
8664: # AND THE CORRESPONDING PATTERN ASSIGNMENTS ARE EXECUTED.
8665: #
8666: # THE FUNCTION OF THE MATCH ROUTINE FOR NDPAD (P$PAD)
8667: # IS SIMPLY TO REMOVE ITS ENTRY FROM THE STACK AND FAIL.
8668: # THIS INCLUDES REMOVING THE SPECIAL NODE POINTER STORED
8669: # IN ADDITION TO THE STANDARD TWO ENTRIES ON THE STACK.
8670: #page
8671: #
8672: # COMPOUNT PATTERN STRUCTURES (CONTINUED)
8673: #
8674: # FENCE (FUNCTION)
8675: # ----------------
8676: #
8677: # +---+ THIS NODE (P$FNA) SAVES THE
8678: # I A I CURRENT HISTORY STACK AND A
8679: # +---+ POINTER TO NDFNB ON THE STACK.
8680: # I
8681: # I
8682: # +---+ THIS IS THE PATTERN STRUCTURE
8683: # I X I GIVEN AS THE ARGUMENT TO THE
8684: # +---+ FENCE FUNCTION.
8685: # I
8686: # I
8687: # +---+ THIS NODE P$FNC RESTORES THE OUTER
8688: # I C I HISTORY STACK PTR SAVED IN P$FNA,
8689: # +---+ AND STACKS THE INNER STACK BASE
8690: # PTR AND A POINTER TO NDFND ON THE
8691: # STACK.
8692: #
8693: # NDFNB (F$FNB) SIMPLY IS THE FAILURE EXIT FOR PATTERN
8694: # ARGUMENT FAILURE, AND IT POPS ITSELF AND FAILS ONTO THE
8695: # STACK.
8696: #
8697: # THE MATCH ROUTINE P$FNC ALLOWS FOR AN OPTIMIZATION WHEN
8698: # THE FENCE PATTERN LEAVES NO ALTERNATIVES. IN THIS CASE,
8699: # THE NDFNB ENTRY IS POPPED, AND THE MATCH CONTINUES.
8700: #
8701: # NDFND (P$FND) IS ENTERED WHEN THE PATTERN FAILS AFTER
8702: # GOING THROUGH A NON-OPTIMIZED P$FNC, AND IT POPS THE
8703: # STACK BACK PAST THE INNTER STACK BASE CREATED BY P$FNA
8704: #page
8705: #
8706: # COMPOUND PATTERNS (CONTINUED)
8707: #
8708: # EXPRESSION PATTERNS (RECURSIVE PATTERN MATCHES)
8709: # -----------------------------------------------
8710: #
8711: # INITIAL ENTRY FOR A PATTERN NODE IS TO THE ROUTINE P$EXA.
8712: # IF THE EVALUATED RESULT OF THE EXPRESSION IS ITSELF A
8713: # PATTERN, THEN THE FOLLOWING STEPS ARE TAKEN TO ARRANGE
8714: # FOR PROPER RECURSIVE PROCESSING.
8715: #
8716: # 1) A POINTER TO THE CURRENT NODE (THE P$EXA NODE) IS
8717: # STORED ON THE HISTORY STACK WITH A DUMMY CURSOR.
8718: #
8719: # 2) A SPECIAL HISTORY STACK ENTRY IS MADE IN WHICH THE
8720: # NODE POINTER POINTS TO NDEXB, AND THE CURSOR VALUE
8721: # IS THE SAVED VALUE OF PMHBS ON ENTRY TO THIS NODE.
8722: # THE MATCH ROUTINE FOR NDEXB (P$EXB) RESTORES PMHBS
8723: # FROM THIS CURSOR ENTRY, POPS OFF THE P$EXA NODE
8724: # POINTER AND FAILS.
8725: #
8726: # 3) THE RESULTING HISTORY STACK POINTER IS SAVED IN
8727: # PMHBS TO ESTABLISH A NEW LEVEL OF HISTORY STACK.
8728: #
8729: # AFTER MATCHING A PATTERN, THE END OF MATCH ROUTINE GETS
8730: # CONTROL (P$NTH). THIS ROUTINE PROCEEDS AS FOLLOWS.
8731: #
8732: # 1) LOAD THE CURRENT VALUE OF PMHBS AND RECOGNIZE THE
8733: # OUTER LEVEL CASE BY THE FACT THAT THE ASSOCIATED
8734: # CURSOR IN THIS CASE IS THE PATTERN MATCH TYPE CODE
8735: # WHICH IS LESS THAN 3. TERMINATE THE MATCH IN THIS
8736: # CASE AND CONTINUE EXECUTION OF THE PROGRAM.
8737: #
8738: # 2) OTHERWISE MAKE A SPECIAL HISTORY STACK ENTRY IN
8739: # WHICH THE NODE POINTER POINTS TO THE SPECIAL NODE
8740: # NDEXC AND THE CURSOR IS THE CURRENT VALUE OF PMHBS.
8741: # THE MATCH ROUTINE FOR NDEXC (P$EXC) RESETS PMHBS TO
8742: # THIS (INNER) VALUE AND AND THEN FAILS.
8743: #
8744: # 3) USING THE HISTORY STACK ENTRY MADE ON STARTING THE
8745: # EXPRESSION (ACCESSIBLE WITH THE CURRENT VALUE OF
8746: # PMHBS), RESTORE THE P$EXA NODE POINTER AND THE OLD
8747: # PMHBS SETTING. TAKE THE SUCCESSOR AND CONTINUE.
8748: #
8749: # AN OPTIMIZATION IS POSSIBLE IF THE EXPRESSION PATTERN
8750: # MAKES NO ENTRIES ON THE HISTORY STACK. IN THIS CASE,
8751: # INSTEAD OF BUILDING THE P$EXC NODE IN STEP 2, IT IS MORE
8752: # EFFICIENT TO SIMPLY POP OFF THE P$EXB ENTRY AND ITS
8753: # ASSOCIATED NODE POINTER. THE EFFECT IS THE SAME.
8754: #page
8755: #
8756: # COMPOUND PATTERNS (CONTINUED)
8757: #
8758: # BINARY DOLLAR (IMMEDIATE ASSIGNMENT)
8759: # ------------------------------------
8760: #
8761: # +---+ THIS NODE (P$IMA) STACKS THE CURSOR
8762: # I A I PMHBS AND A PTR TO NDIMB AND RESETS
8763: # +---+ THE STACK PTR PMHBS.
8764: # I
8765: # I
8766: # +---+ THIS IS THE LEFT STRUCTURE FOR THE
8767: # I X I PATTERN LEFT ARGUMENT OF THE
8768: # +---+ IMMEDIATE ASSIGNMENT CALL.
8769: # I
8770: # I
8771: # +---+ THIS NODE (P$IMC) PERFORMS THE
8772: # I C I----- ASSIGNMENT, POPS PMHBS AND STACKS
8773: # +---+ THE OLD PMHBS AND A PTR TO NDIMD.
8774: #
8775: #
8776: # THE STRUCTURE AND EXECUTION OF THIS PATTERN ARE SIMILAR
8777: # TO THOSE OF THE RECURSIVE EXPRESSION PATTERN MATCHING.
8778: #
8779: # THE MATCH ROUTINE FOR NDIMB (P$IMB) RESTORES THE OUTER
8780: # LEVEL VALUE OF PMHBS, UNSTACKS THE SAVED CURSOR AND FAILS
8781: #
8782: # THE MATCH ROUTINE P$IMC USES THE CURRENT VALUE OF PMHBS
8783: # TO LOCATE THE P$IMB ENTRY. THIS ENTRY IS USED TO MAKE
8784: # THE ASSIGNMENT AND RESTORE THE OUTER LEVEL VALUE OF
8785: # PMHBS. FINALLY, THE INNER LEVEL VALUE OF PMHBS AND A
8786: # POINTER TO THE SPECIAL NODE NDIMD ARE STACKED.
8787: #
8788: # THE MATCH ROUTINE FOR NDIMD (P$IMD) RESTORES THE INNER
8789: # LEVEL VALUE OF PMHBS AND FAILS BACK INTO THE STACK.
8790: #
8791: # AN OPTIMIZATION OCCURS IF THE INNER PATTERN MAKES NO
8792: # ENTRIES ON THE HISTORY STACK. IN THIS CASE, P$IMC POPS
8793: # THE P$IMB ENTRY INSTEAD OF MAKING A P$IMD ENTRY.
8794: #page
8795: #
8796: # ARBNO
8797: #
8798: # SEE COMPOUND PATTERNS SECTION FOR STUCTURE AND
8799: # ALGORITHM FOR MATCHING THIS NODE TYPE.
8800: #
8801: # NO PARAMETERS
8802: #
8803: .align 2
8804: .word bl$p0
8805: p$aba: # p0blk
8806: movl r7,-(sp) # stack cursor
8807: movl r9,-(sp) # stack dummy node ptr
8808: movl pmhbs,-(sp) # stack old stack base ptr
8809: movl $ndabb,-(sp) # stack ptr to node ndabb
8810: movl sp,pmhbs # store new stack base ptr
8811: jmp succp # succeed
8812: #page
8813: #
8814: # ARBNO (REMOVE P$ABA SPECIAL STACK ENTRY)
8815: #
8816: # NO PARAMETERS (DUMMY PATTERN)
8817: #
8818: p$abb: # entry point
8819: movl r7,pmhbs # restore history stack base ptr
8820: jmp flpop # fail and pop dummy node ptr
8821: #page
8822: #
8823: # ARBNO (CHECK IF ARG MATCHED NULL STRING)
8824: #
8825: # NO PARAMETERS (DUMMY PATTERN)
8826: #
8827: .align 2
8828: .word bl$p0
8829: p$abc: # p0blk
8830: movl pmhbs,r10 # keep p$abb stack base
8831: movl 4*3(r10),r6 # load initial cursor
8832: movl 4*1(r10),pmhbs # restore outer stack base ptr
8833: cmpl r10,sp # jump if no history stack entries
8834: beqlu pabc1
8835: movl r10,-(sp) # else save inner pmhbs entry
8836: movl $ndabd,-(sp) # stack ptr to special node ndabd
8837: jmp pabc2 # merge
8838: #
8839: # OPTIMISE CASE OF NO EXTRA ENTRIES ON STACK FROM ARBNO ARG
8840: #
8841: pabc1: addl2 $4*num04,sp # remove ndabb entry and cursor
8842: #
8843: # MERGE TO CHECK FOR MATCHING OF NULL STRING
8844: #
8845: pabc2: cmpl r6,r7 # allow further attempt if non-null
8846: beqlu 0f
8847: jmp succp
8848: 0:
8849: movl 4*pthen(r9),r9 # bypass alternative node so as to ..
8850: jmp succp # ... refuse further match attempts
8851: #page
8852: #
8853: # ARBNO (TRY FOR ALTERNATIVES IN ARBNO ARGUMENT)
8854: #
8855: # NO PARAMETERS (DUMMY PATTERN)
8856: #
8857: p$abd: # entry point
8858: movl r7,pmhbs # restore inner stack base ptr
8859: jmp failp # and fail
8860: #page
8861: #
8862: # ABORT
8863: #
8864: # NO PARAMETERS
8865: #
8866: .align 2
8867: .word bl$p0
8868: p$abo: # p0blk
8869: jmp exfal # signal statement failure
8870: #page
8871: #
8872: # ALTERNATION
8873: #
8874: # PARM1 ALTERNATIVE NODE
8875: #
8876: .align 2
8877: .word bl$p1
8878: p$alt: # p1blk
8879: movl r7,-(sp) # stack cursor
8880: movl 4*parm1(r9),-(sp)# stack pointer to alternative
8881: jsb sbchk # check for stack overflow
8882: jmp succp # if all ok, then succeed
8883: #page
8884: #
8885: # ANY (ONE CHARACTER ARGUMENT) (1-CHAR STRING ALSO)
8886: #
8887: # PARM1 CHARACTER ARGUMENT
8888: #
8889: .align 2
8890: .word bl$p1
8891: p$ans: # p1blk
8892: cmpl r7,pmssl # fail if no chars left
8893: bnequ 0f
8894: jmp failp
8895: 0:
8896: movl r$pms,r10 # else point to subject string
8897: movab cfp$f(r10)[r7],r10 # point to current character
8898: movzbl (r10),r6 # load current character
8899: cmpl r6,4*parm1(r9) # fail if no match
8900: beqlu 0f
8901: jmp failp
8902: 0:
8903: incl r7 # else bump cursor
8904: jmp succp # and succeed
8905: #page
8906: #
8907: # ANY (MULTI-CHARACTER ARGUMENT CASE)
8908: #
8909: # PARM1 POINTER TO CTBLK
8910: # PARM2 BIT MASK TO SELECT BIT IN CTBLK
8911: #
8912: .align 2
8913: .word bl$p2
8914: p$any: # p2blk
8915: #
8916: # EXPRESSION ARGUMENT CASE MERGES HERE
8917: #
8918: pany1: cmpl r7,pmssl # fail if no characters left
8919: bnequ 0f
8920: jmp failp
8921: 0:
8922: movl r$pms,r10 # else point to subject string
8923: movab cfp$f(r10)[r7],r10 # get char ptr to current character
8924: movzbl (r10),r6 # load current character
8925: movl 4*parm1(r9),r10 # point to ctblk
8926: moval 0[r6],r6 # change to byte offset
8927: addl2 r6,r10 # point to entry in ctblk
8928: movl 4*ctchs(r10),r6 # load word from ctblk
8929: mcoml 4*parm2(r9),r11 # and with selected bit
8930: bicl2 r11,r6
8931: bnequ 0f # fail if no match
8932: jmp failp
8933: 0:
8934: incl r7 # else bump cursor
8935: jmp succp # and succeed
8936: #page
8937: #
8938: # ANY (EXPRESSION ARGUMENT)
8939: #
8940: # PARM1 EXPRESSION POINTER
8941: #
8942: .align 2
8943: .word bl$p1
8944: p$ayd: # p1blk
8945: jsb evals # evaluate string argument
8946: .long er_043 # any evaluated argument is not string
8947: .long failp # fail if evaluation failure
8948: .long pany1 # merge multi-char case if ok
8949: #page
8950: #
8951: # P$ARB INITIAL ARB MATCH
8952: #
8953: # NO PARAMETERS
8954: #
8955: # THE P$ARB NODE IS PART OF A COMPOUND PATTERN STRUCTURE
8956: # FOR AN ARB PATTERN (SEE DESCRIPTION OF COMPOUND PATTERNS)
8957: #
8958: .align 2
8959: .word bl$p0
8960: p$arb: # p0blk
8961: movl 4*pthen(r9),r9 # load successor pointer
8962: movl r7,-(sp) # stack dummy cursor
8963: movl r9,-(sp) # stack successor pointer
8964: movl r7,-(sp) # stack cursor
8965: movl $ndarc,-(sp) # stack ptr to special node ndarc
8966: movl (r9),r11 # execute next node matching null
8967: jmp (r11)
8968: #page
8969: #
8970: # P$ARC EXTEND ARB MATCH
8971: #
8972: # NO PARAMETERS (DUMMY PATTERN)
8973: #
8974: p$arc: # entry point
8975: cmpl r7,pmssl # fail and pop stack to successor
8976: bnequ 0f
8977: jmp flpop
8978: 0:
8979: incl r7 # else bump cursor
8980: movl r7,-(sp) # stack updated cursor
8981: movl r9,-(sp) # restack pointer to ndarc node
8982: movl 4*2(sp),r9 # load successor pointer
8983: movl (r9),r11 # off to reexecute successor node
8984: jmp (r11)
8985: #page
8986: #
8987: # BAL
8988: #
8989: # NO PARAMETERS
8990: #
8991: # THE P$BAL NODE IS PART OF THE COMPOUND STRUCTURE BUILT
8992: # FOR BAL (SEE SECTION ON COMPOUND PATTERNS).
8993: #
8994: .align 2
8995: .word bl$p0
8996: p$bal: # p0blk
8997: clrl r8 # zero parentheses level counter
8998: movl r$pms,r10 # point to subject string
8999: movab cfp$f(r10)[r7],r10 # point to current character
9000: jmp pbal2 # jump into scan loop
9001: #
9002: # LOOP TO SCAN OUT CHARACTERS
9003: #
9004: pbal1: movzbl (r10)+,r6 # load next character, bump pointer
9005: incl r7 # push cursor for character
9006: cmpl r6,$ch$pp # jump if left paren
9007: beqlu pbal3
9008: cmpl r6,$ch$rp # jump if right paren
9009: beqlu pbal4
9010: tstl r8 # else succeed if at outer level
9011: beqlu pbal5
9012: #
9013: # HERE AFTER PROCESSING ONE CHARACTER
9014: #
9015: pbal2: cmpl r7,pmssl # loop back unless end of string
9016: bnequ pbal1
9017: jmp failp # in which case, fail
9018: #
9019: # HERE ON LEFT PAREN
9020: #
9021: pbal3: incl r8 # bump paren level
9022: jmp pbal2 # loop back to check end of string
9023: #
9024: # HERE FOR RIGHT PAREN
9025: #
9026: pbal4: tstl r8 # fail if no matching left paren
9027: bnequ 0f
9028: jmp failp
9029: 0:
9030: decl r8 # else decrement level counter
9031: bnequ pbal2 # loop back if not at outer level
9032: #
9033: # HERE AFTER SUCCESSFULLY SCANNING A BALANCED STRING
9034: #
9035: pbal5: movl r7,-(sp) # stack cursor
9036: movl r9,-(sp) # stack ptr to bal node for extend
9037: jmp succp # and succeed
9038: #page
9039: #
9040: # BREAK (EXPRESSION ARGUMENT)
9041: #
9042: # PARM1 EXPRESSION POINTER
9043: #
9044: .align 2
9045: .word bl$p1
9046: p$bkd: # p1blk
9047: jsb evals # evaluate string expression
9048: .long er_044 # break evaluated argument is not string
9049: .long failp # fail if evaluation fails
9050: .long pbrk1 # merge with multi-char case if ok
9051: #page
9052: #
9053: # BREAK (ONE CHARACTER ARGUMENT)
9054: #
9055: # PARM1 CHARACTER ARGUMENT
9056: #
9057: .align 2
9058: .word bl$p1
9059: p$bks: # p1blk
9060: movl pmssl,r8 # get subject string length
9061: subl2 r7,r8 # get number of characters left
9062: bnequ 0f # fail if no characters left
9063: jmp failp
9064: 0:
9065: # set counter for chars left
9066: movl r$pms,r10 # point to subject string
9067: movab cfp$f(r10)[r7],r10 # point to current character
9068: #
9069: # LOOP TO SCAN TILL BREAK CHARACTER FOUND
9070: #
9071: pbks1: movzbl (r10)+,r6 # load next char, bump pointer
9072: cmpl r6,4*parm1(r9) # succeed if break character found
9073: bnequ 0f
9074: jmp succp
9075: 0:
9076: incl r7 # else push cursor
9077: sobgtr r8,pbks1 # loop back if more to go
9078: jmp failp # fail if end of string, no break chr
9079: #page
9080: #
9081: # BREAK (MULTI-CHARACTER ARGUMENT)
9082: #
9083: # PARM1 POINTER TO CTBLK
9084: # PARM2 BIT MASK TO SELECT BIT COLUMN
9085: #
9086: .align 2
9087: .word bl$p2
9088: p$brk: # p2blk
9089: #
9090: # EXPRESSION ARGUMENT MERGES HERE
9091: #
9092: pbrk1: movl pmssl,r8 # load subject string length
9093: subl2 r7,r8 # get number of characters left
9094: bnequ 0f # fail if no characters left
9095: jmp failp
9096: 0:
9097: # set counter for characters left
9098: movl r$pms,r10 # else point to subject string
9099: movab cfp$f(r10)[r7],r10 # point to current character
9100: movl r9,psave # save node pointer
9101: #
9102: # LOOP TO SEARCH FOR BREAK CHARACTER
9103: #
9104: pbrk2: movzbl (r10)+,r6 # load next char, bump pointer
9105: movl 4*parm1(r9),r9 # load pointer to ctblk
9106: moval 0[r6],r6 # convert to byte offset
9107: addl2 r6,r9 # point to ctblk entry
9108: movl 4*ctchs(r9),r6 # load ctblk word
9109: movl psave,r9 # restore node pointer
9110: mcoml 4*parm2(r9),r11 # and with selected bit
9111: bicl2 r11,r6
9112: beqlu 0f # succeed if break character found
9113: jmp succp
9114: 0:
9115: incl r7 # else push cursor
9116: sobgtr r8,pbrk2 # loop back unless end of string
9117: jmp failp # fail if end of string, no break chr
9118: #page
9119: #
9120: # BREAKX (EXTENSION)
9121: #
9122: # THIS IS THE ENTRY WHICH CAUSES AN EXTENSION OF A BREAKX
9123: # MATCH WHEN FAILURE OCCURS. SEE SECTION ON COMPOUND
9124: # PATTERNS FOR FULL DETAILS OF BREAKX MATCHING.
9125: #
9126: # NO PARAMETERS
9127: #
9128: .align 2
9129: .word bl$p0
9130: p$bkx: # p0blk
9131: incl r7 # step cursor past previous break chr
9132: jmp succp # succeed to rematch break
9133: #page
9134: #
9135: # BREAKX (EXPRESSION ARGUMENT)
9136: #
9137: # SEE SECTION ON COMPOUND PATTERNS FOR FULL STRUCTURE OF
9138: # BREAKX PATTERN. THE ACTUAL CHARACTER MATCHING USES A
9139: # BREAK NODE. HOWEVER, THE ENTRY FOR THE EXPRESSION
9140: # ARGUMENT CASE IS SEPARATED TO GET PROPER ERROR MESSAGES.
9141: #
9142: # PARM1 EXPRESSION POINTER
9143: #
9144: .align 2
9145: .word bl$p1
9146: p$bxd: # p1blk
9147: jsb evals # evaluate string argument
9148: .long er_045 # breakx evaluated argument is not string
9149: .long failp # fail if evaluation fails
9150: .long pbrk1 # merge with break if all ok
9151: #page
9152: #
9153: # CURSOR ASSIGNMENT
9154: #
9155: # PARM1 NAME BASE
9156: # PARM2 NAME OFFSET
9157: #
9158: .align 2
9159: .word bl$p2
9160: p$cas: # p2blk
9161: movl r9,-(sp) # save node pointer
9162: movl r7,-(sp) # save cursor
9163: movl 4*parm1(r9),r10 # load name base
9164: movl r7,r5 # load cursor as integer
9165: movl 4*parm2(r9),r7 # load name offset
9166: jsb icbld # get icblk for cursor value
9167: movl r7,r6 # move name offset
9168: movl r9,r7 # move value to assign
9169: jsb asinp # perform assignment
9170: .long flpop # fail on assignment failure
9171: movl (sp)+,r7 # else restore cursor
9172: movl (sp)+,r9 # restore node pointer
9173: jmp succp # and succeed matching null
9174: #page
9175: #
9176: # EXPRESSION NODE (P$EXA, INITIAL ENTRY)
9177: #
9178: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9179: # ALGORITHMS FOR HANDLING EXPRESSION NODES.
9180: #
9181: # PARM1 EXPRESSION POINTER
9182: #
9183: .align 2
9184: .word bl$p1
9185: p$exa: # p1blk
9186: jsb evalp # evaluate expression
9187: .long failp # fail if evaluation fails
9188: cmpl r6,$p$aaa # jump if result is not a pattern
9189: blequ pexa1
9190: #
9191: # HERE IF RESULT OF EXPRESSION IS A PATTERN
9192: #
9193: movl r7,-(sp) # stack dummy cursor
9194: movl r9,-(sp) # stack ptr to p$exa node
9195: movl pmhbs,-(sp) # stack history stack base ptr
9196: movl $ndexb,-(sp) # stack ptr to special node ndexb
9197: movl sp,pmhbs # store new stack base pointer
9198: movl r10,r9 # copy node pointer
9199: movl (r9),r11 # match first node in expression pat
9200: jmp (r11)
9201: #
9202: # HERE IF RESULT OF EXPRESSION IS NOT A PATTERN
9203: #
9204: pexa1: cmpl r6,$b$scl # jump if it is already a string
9205: beqlu pexa2
9206: movl r10,-(sp) # else stack result
9207: movl r9,r10 # save node pointer
9208: jsb gtstg # convert result to string
9209: .long er_046 # expression does not evaluate to pattern
9210: movl r9,r8 # copy string pointer
9211: movl r10,r9 # restore node pointer
9212: movl r8,r10 # copy string pointer again
9213: #
9214: # MERGE HERE WITH STRING POINTER IN XL
9215: #
9216: pexa2: tstl 4*sclen(r10) # just succeed if null string
9217: bnequ 0f
9218: jmp succp
9219: 0:
9220: jmp pstr1 # else merge with string circuit
9221: #page
9222: #
9223: # EXPRESSION NODE (P$EXB, REMOVE NDEXB ENTRY)
9224: #
9225: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9226: # ALGORITHMS FOR HANDLING EXPRESSION NODES.
9227: #
9228: # NO PARAMETERS (DUMMY PATTERN)
9229: #
9230: p$exb: # entry point
9231: movl r7,pmhbs # restore outer level stack pointer
9232: jmp flpop # fail and pop p$exa node ptr
9233: #page
9234: #
9235: # EXPRESSION NODE (P$EXC, REMOVE NDEXC ENTRY)
9236: #
9237: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9238: # ALGORITHMS FOR HANDLING EXPRESSION NODES.
9239: #
9240: # NO PARAMETERS (DUMMY PATTERN)
9241: #
9242: p$exc: # entry point
9243: movl r7,pmhbs # restore inner stack base pointer
9244: jmp failp # and fail into expr pattern alternvs
9245: #page
9246: #
9247: # FAIL
9248: #
9249: # NO PARAMETERS
9250: #
9251: .align 2
9252: .word bl$p0
9253: p$fal: # p0blk
9254: jmp failp # just signal failure
9255: #page
9256: #
9257: # FENCE
9258: #
9259: # SEE COMPOUND PATTERNS SECTION FOR THE STRUCTURE AND
9260: # ALGORITHM FOR MATCHING THIS NODE TYPE.
9261: #
9262: # NO PARAMETERS
9263: #
9264: .align 2
9265: .word bl$p0
9266: p$fen: # p0blk
9267: movl r7,-(sp) # stack dummy cursor
9268: movl $ndabo,-(sp) # stack ptr to abort node
9269: jmp succp # and succeed matching null
9270: #page
9271: #
9272: # FENCE (FUNCTION)
9273: #
9274: # SEE COMPOUND PATTERNS COMMENTS AT START OF THIS SECTION
9275: # FOR DETAILS OF SCHEME
9276: #
9277: # NO PARAMETERS
9278: #
9279: .align 2
9280: .word bl$p0
9281: p$fna: # p0blk
9282: movl pmhbs,-(sp) # stack current history stack base
9283: movl $ndfnb,-(sp) # stack indir ptr to p$fnb (failure)
9284: movl sp,pmhbs # begin new history stack
9285: jmp succp # succeed
9286: #page
9287: #
9288: # FENCE (FUNCTION) (RESET HISTORY STACK AND FAIL)
9289: #
9290: # NO PARAMETERS (DUMMY PATTERN)
9291: #
9292: .align 2
9293: .word bl$p0
9294: p$fnb: # p0blk
9295: movl r7,pmhbs # restore outer pmhbs stack base
9296: jmp failp # ...and fail
9297: #page
9298: #
9299: # FENCE (FUNCTION) (MAKE FENCE TRAP ENTRY ON STACK)
9300: #
9301: # NO PARAMETERS (DUMMY PATTERN)
9302: #
9303: .align 2
9304: .word bl$p0
9305: p$fnc: # p0blk
9306: movl pmhbs,r10 # get inner stack base ptr
9307: movl 4*num01(r10),pmhbs # restore outer stack base
9308: cmpl r10,sp # optimize if no alternatives
9309: beqlu pfnc1
9310: movl r10,-(sp) # else stack inner stack base
9311: movl $ndfnd,-(sp) # stack ptr to ndfnd
9312: jmp succp # succeed
9313: #
9314: # HERE WHEN FENCE FUNCTION LEFT NOTHING ON THE STACK
9315: #
9316: pfnc1: addl2 $4*num02,sp # pop off p$fnb entry
9317: jmp succp # succeed
9318: #page
9319: #
9320: # FENCE (FUNCTION) (SKIP PAST ALTERNATIVES ON FAILURE)
9321: #
9322: # NO PARAMETERS (DUMMY PATTERN)
9323: #
9324: .align 2
9325: .word bl$p0
9326: p$fnd: # p0blk
9327: movl r7,sp # pop stack to fence() history base
9328: jmp flpop # pop base entry and fail
9329: #page
9330: #
9331: # IMMEDIATE ASSIGNMENT (INITIAL ENTRY, SAVE CURRENT CURSOR)
9332: #
9333: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
9334: # STRUCTURE AND ALGORITHM FOR MATCHING THIS NODE TYPE.
9335: #
9336: # NO PARAMETERS
9337: #
9338: .align 2
9339: .word bl$p0
9340: p$ima: # p0blk
9341: movl r7,-(sp) # stack cursor
9342: movl r9,-(sp) # stack dummy node pointer
9343: movl pmhbs,-(sp) # stack old stack base pointer
9344: movl $ndimb,-(sp) # stack ptr to special node ndimb
9345: movl sp,pmhbs # store new stack base pointer
9346: jmp succp # and succeed
9347: #page
9348: #
9349: # IMMEDIATE ASSIGNMENT (REMOVE CURSOR MARK ENTRY)
9350: #
9351: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
9352: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
9353: #
9354: # NO PARAMETERS (DUMMY PATTERN)
9355: #
9356: p$imb: # entry point
9357: movl r7,pmhbs # restore history stack base ptr
9358: jmp flpop # fail and pop dummy node ptr
9359: #page
9360: #
9361: # IMMEDIATE ASSIGNMENT (PERFORM ACTUAL ASSIGNMENT)
9362: #
9363: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
9364: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
9365: #
9366: # PARM1 NAME BASE OF VARIABLE
9367: # PARM2 NAME OFFSET OF VARIABLE
9368: #
9369: .align 2
9370: .word bl$p2
9371: p$imc: # p2blk
9372: movl pmhbs,r10 # load pointer to p$imb entry
9373: movl r7,r6 # copy final cursor
9374: movl 4*3(r10),r7 # load initial cursor
9375: movl 4*1(r10),pmhbs # restore outer stack base pointer
9376: cmpl r10,sp # jump if no history stack entries
9377: beqlu pimc1
9378: movl r10,-(sp) # else save inner pmhbs pointer
9379: movl $ndimd,-(sp) # and a ptr to special node ndimd
9380: jmp pimc2 # merge
9381: #
9382: # HERE IF NO ENTRIES MADE ON HISTORY STACK
9383: #
9384: pimc1: addl2 $4*num04,sp # remove ndimb entry and cursor
9385: #
9386: # MERGE HERE TO PERFORM ASSIGNMENT
9387: #
9388: pimc2: movl r6,-(sp) # save current (final) cursor
9389: movl r9,-(sp) # save current node pointer
9390: movl r$pms,r10 # point to subject string
9391: subl2 r7,r6 # compute substring length
9392: jsb sbstr # build substring
9393: movl r9,r7 # move result
9394: movl (sp),r9 # reload node pointer
9395: movl 4*parm1(r9),r10 # load name base
9396: movl 4*parm2(r9),r6 # load name offset
9397: jsb asinp # perform assignment
9398: .long flpop # fail if assignment fails
9399: movl (sp)+,r9 # else restore node pointer
9400: movl (sp)+,r7 # restore cursor
9401: jmp succp # and succeed
9402: #page
9403: #
9404: # IMMEDIATE ASSIGNMENT (REMOVE NDIMD ENTRY ON FAILURE)
9405: #
9406: # SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
9407: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
9408: #
9409: # NO PARAMETERS (DUMMY PATTERN)
9410: #
9411: p$imd: # entry point
9412: movl r7,pmhbs # restore inner stack base pointer
9413: jmp failp # and fail
9414: #page
9415: #
9416: # LEN (INTEGER ARGUMENT)
9417: #
9418: # PARM1 INTEGER ARGUMENT
9419: #
9420: .align 2
9421: .word bl$p1
9422: p$len: # p1blk
9423: #
9424: # EXPRESSION ARGUMENT CASE MERGES HERE
9425: #
9426: plen1: addl2 4*parm1(r9),r7 # push cursor indicated amount
9427: cmpl r7,pmssl # succeed if not off end
9428: bgtru 0f
9429: jmp succp
9430: 0:
9431: jmp failp # else fail
9432: #page
9433: #
9434: # LEN (EXPRESSION ARGUMENT)
9435: #
9436: # PARM1 EXPRESSION POINTER
9437: #
9438: .align 2
9439: .word bl$p1
9440: p$lnd: # p1blk
9441: jsb evali # evaluate integer argument
9442: .long er_047 # len evaluated argument is not integer
9443: .long er_048 # len evaluated argument is negative or too large
9444: .long failp # fail if evaluation fails
9445: .long plen1 # merge with normal circuit if ok
9446: #page
9447: #
9448: # NOTANY (EXPRESSION ARGUMENT)
9449: #
9450: # PARM1 EXPRESSION POINTER
9451: #
9452: .align 2
9453: .word bl$p1
9454: p$nad: # p1blk
9455: jsb evals # evaluate string argument
9456: .long er_049 # notany evaluated argument is not string
9457: .long failp # fail if evaluation fails
9458: .long pnay1 # merge with multi-char case if ok
9459: #page
9460: #
9461: # NOTANY (ONE CHARACTER ARGUMENT)
9462: #
9463: # PARM1 CHARACTER ARGUMENT
9464: #
9465: .align 2
9466: .word bl$p1
9467: p$nas: # entry point
9468: cmpl r7,pmssl # fail if no chars left
9469: bnequ 0f
9470: jmp failp
9471: 0:
9472: movl r$pms,r10 # else point to subject string
9473: movab cfp$f(r10)[r7],r10 # point to current character in strin
9474: movzbl (r10),r6 # load current character
9475: cmpl r6,4*parm1(r9) # fail if match
9476: bnequ 0f
9477: jmp failp
9478: 0:
9479: incl r7 # else bump cursor
9480: jmp succp # and succeed
9481: #page
9482: #
9483: # NOTANY (MULTI-CHARACTER STRING ARGUMENT)
9484: #
9485: # PARM1 POINTER TO CTBLK
9486: # PARM2 BIT MASK TO SELECT BIT COLUMN
9487: #
9488: .align 2
9489: .word bl$p2
9490: p$nay: # p2blk
9491: #
9492: # EXPRESSION ARGUMENT CASE MERGES HERE
9493: #
9494: pnay1: cmpl r7,pmssl # fail if no characters left
9495: bnequ 0f
9496: jmp failp
9497: 0:
9498: movl r$pms,r10 # else point to subject string
9499: movab cfp$f(r10)[r7],r10 # point to current character
9500: movzbl (r10),r6 # load current character
9501: moval 0[r6],r6 # convert to byte offset
9502: movl 4*parm1(r9),r10 # load pointer to ctblk
9503: addl2 r6,r10 # point to entry in ctblk
9504: movl 4*ctchs(r10),r6 # load entry from ctblk
9505: mcoml 4*parm2(r9),r11 # and with selected bit
9506: bicl2 r11,r6
9507: beqlu 0f # fail if character is matched
9508: jmp failp
9509: 0:
9510: incl r7 # else bump cursor
9511: jmp succp # and succeed
9512: #page
9513: #
9514: # END OF PATTERN MATCH
9515: #
9516: # THIS ROUTINE IS ENTERED ON SUCCESSFUL COMPLETION.
9517: # SEE DESCRIPTION OF EXPRESSION PATTERNS IN COMPOUND
9518: # PATTERN SECTION FOR HANDLING OF RECURSION IN MATCHING.
9519: #
9520: # NO PARAMETERS (DUMMY PATTERN)
9521: #
9522: p$nth: # entry point
9523: movl pmhbs,r10 # load pointer to base of stack
9524: movl 4*1(r10),r6 # load saved pmhbs (or pattern type)
9525: cmpl r6,$num02 # jump if outer level (pattern type)
9526: blequ pnth2
9527: #
9528: # HERE WE ARE AT THE END OF MATCHING AN EXPRESSION PATTERN
9529: #
9530: movl r6,pmhbs # restore outer stack base pointer
9531: movl 4*2(r10),r9 # restore pointer to p$exa node
9532: cmpl r10,sp # jump if no history stack entries
9533: beqlu pnth1
9534: movl r10,-(sp) # else stack inner stack base ptr
9535: movl $ndexc,-(sp) # stack ptr to special node ndexc
9536: jmp succp # and succeed
9537: #
9538: # HERE IF NO HISTORY STACK ENTRIES DURING PATTERN
9539: #
9540: pnth1: addl2 $4*num04,sp # remove p$exb entry and node ptr
9541: jmp succp # and succeed
9542: #
9543: # HERE IF END OF MATCH AT OUTER LEVEL
9544: #
9545: pnth2: movl r7,pmssl # save final cursor in safe place
9546: tstl pmdfl # jump if no pattern assignments
9547: beqlu pnth6
9548: #page
9549: #
9550: # END OF PATTERN MATCH (CONTINUED)
9551: #
9552: # NOW WE MUST PERFORM PATTERN ASSIGNMENTS. THIS IS DONE BY
9553: # SCANNING THE HISTORY STACK FOR MATCHING NDPAB-NDPAD PAIRS
9554: #
9555: pnth3: subl2 $4,r10 # point past cursor entry
9556: movl -(r10),r6 # load node pointer
9557: cmpl r6,$ndpad # jump if ndpad entry
9558: beqlu pnth4
9559: cmpl r6,$ndpab # jump if not ndpab entry
9560: bnequ pnth5
9561: #
9562: # HERE FOR NDPAB ENTRY, STACK INITIAL CURSOR
9563: # NOTE THAT THERE MUST BE MORE ENTRIES ON THE STACK.
9564: #
9565: movl 4*1(r10),-(sp) # stack initial cursor
9566: jsb sbchk # check for stack overflow
9567: jmp pnth3 # loop back if ok
9568: #
9569: # HERE FOR NDPAD ENTRY. THE STARTING CURSOR FROM THE
9570: # MATCHING NDPAD ENTRY IS NOW THE TOP STACK ENTRY.
9571: #
9572: pnth4: movl 4*1(r10),r6 # load final cursor
9573: movl (sp),r7 # load initial cursor from stack
9574: movl r10,(sp) # save history stack scan ptr
9575: subl2 r7,r6 # compute length of string
9576: #
9577: # BUILD SUBSTRING AND PERFORM ASSIGNMENT
9578: #
9579: movl r$pms,r10 # point to subject string
9580: jsb sbstr # construct substring
9581: movl r9,r7 # copy substring pointer
9582: movl (sp),r10 # reload history stack scan ptr
9583: movl 4*2(r10),r10 # load pointer to p$pac node with nam
9584: movl 4*parm2(r10),r6 # load name offset
9585: movl 4*parm1(r10),r10# load name base
9586: jsb asinp # perform assignment
9587: .long exfal # match fails if name eval fails
9588: movl (sp)+,r10 # else restore history stack ptr
9589: #page
9590: #
9591: # END OF PATTERN MATCH (CONTINUED)
9592: #
9593: # HERE CHECK FOR END OF ENTRIES
9594: #
9595: pnth5: cmpl r10,sp # loop if more entries to scan
9596: bnequ pnth3
9597: #
9598: # HERE AFTER DEALING WITH PATTERN ASSIGNMENTS
9599: #
9600: pnth6: movl pmhbs,sp # wipe out history stack
9601: movl (sp)+,r7 # load initial cursor
9602: movl (sp)+,r8 # load match type code
9603: movl pmssl,r6 # load final cursor value
9604: movl r$pms,r10 # point to subject string
9605: clrl r$pms # clear subject string ptr for gbcol
9606: tstl r8 # jump if call by name
9607: beqlu pnth7
9608: cmpl r8,$num02 # exit if statement level call
9609: bnequ 0f
9610: jmp exits
9611: 0:
9612: #
9613: # HERE WE HAVE A CALL BY VALUE, BUILD SUBSTRING
9614: #
9615: subl2 r7,r6 # compute length of string
9616: jsb sbstr # build substring
9617: jmp exixr # and exit with substring value
9618: #
9619: # HERE FOR CALL BY NAME, MAKE STACK ENTRIES FOR O$RPL
9620: #
9621: pnth7: movl r7,-(sp) # stack initial cursor
9622: movl r6,-(sp) # stack final cursor
9623: tstl r$pmb # skip if subject not buffer
9624: beqlu pnth8
9625: movl r$pmb,r10 # else get ptr to bcblk instead
9626: #
9627: # HERE WITH XL POINTING TO SCBLK OR BCBLK
9628: #
9629: pnth8: movl r10,-(sp) # stack subject pointer
9630: jmp exits # exit with special entry on stack
9631: #page
9632: #
9633: # POS (INTEGER ARGUMENT)
9634: #
9635: # PARM1 INTEGER ARGUMENT
9636: #
9637: .align 2
9638: .word bl$p1
9639: p$pos: # p1blk
9640: #
9641: # EXPRESSION ARGUMENT CASE MERGES HERE
9642: #
9643: ppos1: cmpl r7,4*parm1(r9) # succeed if at right location
9644: bnequ 0f
9645: jmp succp
9646: 0:
9647: jmp failp # else fail
9648: #page
9649: #
9650: # POS (EXPRESSION ARGUMENT)
9651: #
9652: # PARM1 EXPRESSION POINTER
9653: #
9654: .align 2
9655: .word bl$p1
9656: p$psd: # p1blk
9657: jsb evali # evaluate integer argument
9658: .long er_050 # pos evaluated argument is not integer
9659: .long er_051 # pos evaluated argument is negative or too large
9660: .long failp # fail if evaluation fails
9661: .long ppos1 # merge with normal case if ok
9662: #page
9663: #
9664: # PATTERN ASSIGNMENT (INITIAL ENTRY, SAVE CURSOR)
9665: #
9666: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9667: # ALGORITHMS FOR MATCHING THIS NODE TYPE.
9668: #
9669: # NO PARAMETERS
9670: #
9671: .align 2
9672: .word bl$p0
9673: p$paa: # p0blk
9674: movl r7,-(sp) # stack initial cursor
9675: movl $ndpab,-(sp) # stack ptr to ndpab special node
9676: jmp succp # and succeed matching null
9677: #page
9678: #
9679: # PATTERN ASSIGNMENT (REMOVE SAVED CURSOR)
9680: #
9681: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9682: # ALGORITHMS FOR MATCHING THIS NODE TYPE.
9683: #
9684: # NO PARAMETERS (DUMMY PATTERN)
9685: #
9686: p$pab: # entry point
9687: jmp failp # just fail (entry is already popped)
9688: #page
9689: #
9690: # PATTERN ASSIGNMENT (END OF MATCH, MAKE ASSIGN ENTRY)
9691: #
9692: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9693: # ALGORITHMS FOR MATCHING THIS NODE TYPE.
9694: #
9695: # PARM1 NAME BASE OF VARIABLE
9696: # PARM2 NAME OFFSET OF VARIABLE
9697: #
9698: .align 2
9699: .word bl$p2
9700: p$pac: # p2blk
9701: movl r7,-(sp) # stack dummy cursor value
9702: movl r9,-(sp) # stack pointer to p$pac node
9703: movl r7,-(sp) # stack final cursor
9704: movl $ndpad,-(sp) # stack ptr to special ndpad node
9705: movl sp,pmdfl # set dot flag non-zero
9706: jmp succp # and succeed
9707: #page
9708: #
9709: # PATTERN ASSIGNMENT (REMOVE ASSIGN ENTRY)
9710: #
9711: # SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
9712: # ALGORITHMS FOR MATCHING THIS NODE TYPE.
9713: #
9714: # NO PARAMETERS (DUMMY NODE)
9715: #
9716: p$pad: # entry point
9717: jmp flpop # fail and remove p$pac node
9718: #page
9719: #
9720: # REM
9721: #
9722: # NO PARAMETERS
9723: #
9724: .align 2
9725: .word bl$p0
9726: p$rem: # p0blk
9727: movl pmssl,r7 # point cursor to end of string
9728: jmp succp # and succeed
9729: #page
9730: #
9731: # RPOS (EXPRESSION ARGUMENT)
9732: #
9733: # PARM1 EXPRESSION POINTER
9734: #
9735: .align 2
9736: .word bl$p1
9737: p$rpd: # p1blk
9738: jsb evali # evaluate integer argument
9739: .long er_052 # rpos evaluated argument is not integer
9740: .long er_053 # rpos evaluated argument is negative or too large
9741: .long failp # fail if evaluation fails
9742: .long prps1 # merge with normal case if ok
9743: #page
9744: #
9745: # RPOS (INTEGER ARGUMENT)
9746: #
9747: # PARM1 INTEGER ARGUMENT
9748: #
9749: .align 2
9750: .word bl$p1
9751: p$rps: # p1blk
9752: #
9753: # EXPRESSION ARGUMENT CASE MERGES HERE
9754: #
9755: prps1: movl pmssl,r8 # get length of string
9756: subl2 r7,r8 # get number of characters remaining
9757: cmpl r8,4*parm1(r9) # succeed if at right location
9758: bnequ 0f
9759: jmp succp
9760: 0:
9761: jmp failp # else fail
9762: #page
9763: #
9764: # RTAB (INTEGER ARGUMENT)
9765: #
9766: # PARM1 INTEGER ARGUMENT
9767: #
9768: .align 2
9769: .word bl$p1
9770: p$rtb: # p1blk
9771: #
9772: # EXPRESSION ARGUMENT CASE MERGES HERE
9773: #
9774: prtb1: movl r7,r8 # save initial cursor
9775: movl pmssl,r7 # point to end of string
9776: cmpl r7,4*parm1(r9) # fail if string not long enough
9777: bgequ 0f
9778: jmp failp
9779: 0:
9780: subl2 4*parm1(r9),r7 # else set new cursor
9781: cmpl r7,r8 # and succeed if not too far already
9782: blssu 0f
9783: jmp succp
9784: 0:
9785: jmp failp # in which case, fail
9786: #page
9787: #
9788: # RTAB (EXPRESSION ARGUMENT)
9789: #
9790: # PARM1 EXPRESSION POINTER
9791: #
9792: .align 2
9793: .word bl$p1
9794: p$rtd: # p1blk
9795: jsb evali # evaluate integer argument
9796: .long er_054 # rtab evaluated argument is not integer
9797: .long er_055 # rtab evaluated argument is negative or too large
9798: .long failp # fail if evaluation fails
9799: .long prtb1 # merge with normal case if success
9800: #page
9801: #
9802: # SPAN (EXPRESSION ARGUMENT)
9803: #
9804: # PARM1 EXPRESSION POINTER
9805: #
9806: .align 2
9807: .word bl$p1
9808: p$spd: # p1blk
9809: jsb evals # evaluate string argument
9810: .long er_056 # span evaluated argument is not string
9811: .long failp # fail if evaluation fails
9812: .long pspn1 # merge with multi-char case if ok
9813: #page
9814: #
9815: # SPAN (MULTI-CHARACTER ARGUMENT CASE)
9816: #
9817: # PARM1 POINTER TO CTBLK
9818: # PARM2 BIT MASK TO SELECT BIT COLUMN
9819: #
9820: .align 2
9821: .word bl$p2
9822: p$spn: # p2blk
9823: #
9824: # EXPRESSION ARGUMENT CASE MERGES HERE
9825: #
9826: pspn1: movl pmssl,r8 # copy subject string length
9827: subl2 r7,r8 # calculate number of characters left
9828: bnequ 0f # fail if no characters left
9829: jmp failp
9830: 0:
9831: movl r$pms,r10 # point to subject string
9832: movab cfp$f(r10)[r7],r10 # point to current character
9833: movl r7,psavc # save initial cursor
9834: movl r9,psave # save node pointer
9835: # set counter for chars left
9836: #
9837: # LOOP TO SCAN MATCHING CHARACTERS
9838: #
9839: pspn2: movzbl (r10)+,r6 # load next character, bump pointer
9840: moval 0[r6],r6 # convert to byte offset
9841: movl 4*parm1(r9),r9 # point to ctblk
9842: addl2 r6,r9 # point to ctblk entry
9843: movl 4*ctchs(r9),r6 # load ctblk entry
9844: movl psave,r9 # restore node pointer
9845: mcoml 4*parm2(r9),r11 # and with selected bit
9846: bicl2 r11,r6
9847: beqlu pspn3 # jump if no match
9848: incl r7 # else push cursor
9849: sobgtr r8,pspn2 # loop back unless end of string
9850: #
9851: # HERE AFTER SCANNING MATCHING CHARACTERS
9852: #
9853: pspn3: cmpl r7,psavc # succeed if chars matched
9854: beqlu 0f
9855: jmp succp
9856: 0:
9857: jmp failp # else fail if null string matched
9858: #page
9859: #
9860: # SPAN (ONE CHARACTER ARGUMENT)
9861: #
9862: # PARM1 CHARACTER ARGUMENT
9863: #
9864: .align 2
9865: .word bl$p1
9866: p$sps: # p1blk
9867: movl pmssl,r8 # get subject string length
9868: subl2 r7,r8 # calculate number of characters left
9869: bnequ 0f # fail if no characters left
9870: jmp failp
9871: 0:
9872: movl r$pms,r10 # else point to subject string
9873: movab cfp$f(r10)[r7],r10 # point to current character
9874: movl r7,psavc # save initial cursor
9875: # set counter for characters left
9876: #
9877: # LOOP TO SCAN MATCHING CHARACTERS
9878: #
9879: psps1: movzbl (r10)+,r6 # load next character, bump pointer
9880: cmpl r6,4*parm1(r9) # jump if no match
9881: bnequ psps2
9882: incl r7 # else push cursor
9883: sobgtr r8,psps1 # and loop unless end of string
9884: #
9885: # HERE AFTER SCANNING MATCHING CHARACTERS
9886: #
9887: psps2: cmpl r7,psavc # succeed if chars matched
9888: beqlu 0f
9889: jmp succp
9890: 0:
9891: jmp failp # fail if null string matched
9892: #page
9893: #
9894: # MULTI-CHARACTER STRING
9895: #
9896: # NOTE THAT ONE CHARACTER STRINGS USE THE CIRCUIT FOR
9897: # ONE CHARACTER ANY ARGUMENTS (P$AN1).
9898: #
9899: # PARM1 POINTER TO SCBLK FOR STRING ARG
9900: #
9901: .align 2
9902: .word bl$p1
9903: p$str: # p1blk
9904: movl 4*parm1(r9),r10 # get pointer to string
9905: #
9906: # MERGE HERE AFTER EVALUATING EXPRESSION WITH STRING VALUE
9907: #
9908: pstr1: movl r9,psave # save node pointer
9909: movl r$pms,r9 # load subject string pointer
9910: movab cfp$f(r9)[r7],r9# point to current character
9911: addl2 4*sclen(r10),r7 # compute new cursor position
9912: cmpl r7,pmssl # fail if past end of string
9913: blequ 0f
9914: jmp failp
9915: 0:
9916: movl r7,psavc # save updated cursor
9917: movl 4*sclen(r10),r6 # get number of chars to compare
9918: movab cfp$f(r10),r10 # point to chars of test string
9919: jsb sbcmc # compare, fail if not equal
9920: .long failp
9921: .long failp
9922: movl psave,r9 # if all matched, restore node ptr
9923: movl psavc,r7 # restore updated cursor
9924: jmp succp # and succeed
9925: #page
9926: #
9927: # SUCCEED
9928: #
9929: # SEE SECTION ON COMPOUND PATTERNS FOR DETAILS OF THE
9930: # STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE
9931: #
9932: # NO PARAMETERS
9933: #
9934: .align 2
9935: .word bl$p0
9936: p$suc: # p0blk
9937: movl r7,-(sp) # stack cursor
9938: movl r9,-(sp) # stack pointer to this node
9939: jmp succp # succeed matching null
9940: #page
9941: #
9942: # TAB (INTEGER ARGUMENT)
9943: #
9944: # PARM1 INTEGER ARGUMENT
9945: #
9946: .align 2
9947: .word bl$p1
9948: p$tab: # p1blk
9949: #
9950: # EXPRESSION ARGUMENT CASE MERGES HERE
9951: #
9952: ptab1: cmpl r7,4*parm1(r9) # fail if too far already
9953: blequ 0f
9954: jmp failp
9955: 0:
9956: movl 4*parm1(r9),r7 # else set new cursor position
9957: cmpl r7,pmssl # succeed if not off end
9958: bgtru 0f
9959: jmp succp
9960: 0:
9961: jmp failp # else fail
9962: #page
9963: #
9964: # TAB (EXPRESSION ARGUMENT)
9965: #
9966: # PARM1 EXPRESSION POINTER
9967: #
9968: .align 2
9969: .word bl$p1
9970: p$tbd: # p1blk
9971: jsb evali # evaluate integer argument
9972: .long er_057 # tab evaluated argument is not integer
9973: .long er_058 # tab evaluated argument is negative or too large
9974: .long failp # fail if evaluation fails
9975: .long ptab1 # merge with normal case if ok
9976: #page
9977: #
9978: # ANCHOR MOVEMENT
9979: #
9980: # NO PARAMETERS (DUMMY NODE)
9981: #
9982: p$una: # entry point
9983: movl r7,r9 # copy initial pattern node pointer
9984: movl (sp),r7 # get initial cursor
9985: cmpl r7,pmssl # match fails if at end of string
9986: bnequ 0f
9987: jmp exfal
9988: 0:
9989: incl r7 # else increment cursor
9990: movl r7,(sp) # store incremented cursor
9991: movl r9,-(sp) # restack initial node ptr
9992: movl $nduna,-(sp) # restack unanchored node
9993: movl (r9),r11 # rematch first node
9994: jmp (r11)
9995: #page
9996: #
9997: # END OF PATTERN MATCH ROUTINES
9998: #
9999: # THE FOLLOWING ENTRY POINT MARKS THE END OF THE PATTERN
10000: # MATCHING ROUTINES AND ALSO THE END OF THE ENTRY POINTS
10001: # REFERENCED FROM THE FIRST WORD OF BLOCKS IN DYNAMIC STORE
10002: #
10003: .align 2
10004: .word bl$$i
10005: p$yyy: # mark last entry in pattern section
10006: #title s p i t b o l -- predefined snobol4 functions
10007: #
10008: # THE FOLLOWING SECTION CONTAINS CODING FOR FUNCTIONS
10009: # WHICH ARE PREDEFINED AND AVAILABLE AT THE SNOBOL LEVEL.
10010: #
10011: # THESE ROUTINES RECEIVE CONTROL DIRECTLY FROM THE CODE OR
10012: # INDIRECTLY THROUGH THE O$FNC, O$FNS OR CFUNC ROUTINES.
10013: # IN BOTH CASES THE CONDITIONS ON ENTRY ARE AS FOLLOWS
10014: #
10015: # THE ARGUMENTS ARE ON THE STACK. THE NUMBER OF ARGUMENTS
10016: # HAS BEEN ADJUSTED TO CORRESPOND TO THE SVBLK SVNAR FIELD.
10017: #
10018: # IN CERTAIN FUNCTIONS THE DIRECT CALL IS NOT PERMITTED
10019: # AND IN THESE INSTANCES WE ALSO HAVE.
10020: #
10021: # (WA) ACTUAL NUMBER OF ARGUMENTS IN CALL
10022: #
10023: # CONTROL RETURNS BY PLACING THE FUNCTION RESULT VALUE ON
10024: # ON THE STACK AND CONTINUING EXECUTION WITH THE NEXT
10025: # WORD FROM THE GENERATED CODE.
10026: #
10027: # THE NAMES OF THE ENTRY POINTS OF THESE FUNCTIONS ARE OF
10028: # THE FORM S$XXX WHERE XXX IS THE THREE LETTER CODE FOR
10029: # THE SYSTEM VARIABLE NAME. THE FUNCTIONS ARE IN ORDER
10030: # ALPHABETICALLY BY THEIR ENTRY NAMES.
10031: #page
10032: #
10033: # ANY
10034: #
10035: s$any: # entry point
10036: movl $p$ans,r7 # set pcode for single char case
10037: movl $p$any,r10 # pcode for multi-char case
10038: movl $p$ayd,r8 # pcode for expression case
10039: jsb patst # call common routine to build node
10040: .long er_059 # any argument is not string or expression
10041: jmp exixr # jump for next code word
10042: #page
10043: #
10044: # APPEND
10045: #
10046: s$apn: # entry point
10047: movl (sp)+,r10 # get append argument
10048: movl (sp)+,r9 # get bcblk
10049: cmpl (r9),$b$bct # ok if first arg is bcblk
10050: beqlu sapn1
10051: jmp er_275 # append first argument is not buffer
10052: #
10053: # HERE TO DO THE APPEND
10054: #
10055: sapn1: jsb apndb # do the append
10056: .long er_276 # append second argument is not string
10057: .long exfal # no room - fail
10058: jmp exnul # exit with null result
10059: #page
10060: #
10061: # APPLY
10062: #
10063: # APPLY DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
10064: # WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
10065: #
10066: s$app: # entry point
10067: tstl r6 # jump if no arguments
10068: beqlu sapp3
10069: decl r6 # else get applied func arg count
10070: movl r6,r7 # copy
10071: moval 0[r7],r7 # convert to bytes
10072: movl sp,r10 # copy stack pointer
10073: addl2 r7,r10 # point to function argument on stack
10074: movl (r10),r9 # load function ptr (apply 1st arg)
10075: tstl r6 # jump if no args for applied func
10076: beqlu sapp2
10077: movl r6,r7 # else set counter for loop
10078: #
10079: # LOOP TO MOVE ARGUMENTS UP ON STACK
10080: #
10081: sapp1: subl2 $4,r10 # point to next argument
10082: movl (r10),4*1(r10) # move argument up
10083: sobgtr r7,sapp1 # loop till all moved
10084: #
10085: # MERGE HERE TO CALL FUNCTION (WA = NUMBER OF ARGUMENTS)
10086: #
10087: sapp2: addl2 $4,sp # adjust stack ptr for apply 1st arg
10088: jsb gtnvr # get variable block addr for func
10089: .long sapp3 # jump if not natural variable
10090: movl 4*vrfnc(r9),r10 # else point to function block
10091: jmp cfunc # go call applied function
10092: #
10093: # HERE FOR INVALID FIRST ARGUMENT
10094: #
10095: sapp3: jmp er_060 # apply first arg is not natural variable name
10096: #page
10097: #
10098: # ARBNO
10099: #
10100: # ARBNO BUILDS A COMPOUND PATTERN. SEE DESCRIPTION AT
10101: # START OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
10102: #
10103: s$abn: # entry point
10104: clrl r9 # set parm1 = 0 for the moment
10105: movl $p$alt,r7 # set pcode for alternative node
10106: jsb pbild # build alternative node
10107: movl r9,r10 # save ptr to alternative pattern
10108: movl $p$abc,r7 # pcode for p$abc
10109: clrl r9 # p0blk
10110: jsb pbild # build p$abc node
10111: movl r10,4*pthen(r9) # put alternative node as successor
10112: movl r10,r6 # remember alternative node pointer
10113: movl r9,r10 # copy p$abc node ptr
10114: movl (sp),r9 # load arbno argument
10115: movl r6,(sp) # stack alternative node pointer
10116: jsb gtpat # get arbno argument as pattern
10117: .long er_061 # arbno argument is not pattern
10118: jsb pconc # concat arg with p$abc node
10119: movl r9,r10 # remember ptr to concd patterns
10120: movl $p$aba,r7 # pcode for p$aba
10121: clrl r9 # p0blk
10122: jsb pbild # build p$aba node
10123: movl r10,4*pthen(r9) # concatenate nodes
10124: movl (sp),r10 # recall ptr to alternative node
10125: movl r9,4*parm1(r10) # point alternative back to argument
10126: jmp exits # jump for next code word
10127: #page
10128: #
10129: # ARG
10130: #
10131: s$arg: # entry point
10132: jsb gtsmi # get second arg as small integer
10133: .long er_062 # arg second argument is not integer
10134: .long exfal # fail if out of range or negative
10135: movl r9,r6 # save argument number
10136: movl (sp)+,r9 # load first argument
10137: jsb gtnvr # locate vrblk
10138: .long sarg1 # jump if not natural variable
10139: movl 4*vrfnc(r9),r9 # else load function block pointer
10140: cmpl (r9),$b$pfc # jump if not program defined
10141: bnequ sarg1
10142: tstl r6 # fail if arg number is zero
10143: bnequ 0f
10144: jmp exfal
10145: 0:
10146: cmpl r6,4*fargs(r9) # fail if arg number is too large
10147: blequ 0f
10148: jmp exfal
10149: 0:
10150: moval 0[r6],r6 # else convert to byte offset
10151: addl2 r6,r9 # point to argument selected
10152: movl 4*pfagb(r9),r9 # load argument vrblk pointer
10153: jmp exvnm # exit to build nmblk
10154: #
10155: # HERE IF 1ST ARGUMENT IS BAD
10156: #
10157: sarg1: jmp er_063 # arg first argument is not program function name
10158: #page
10159: #
10160: # ARRAY
10161: #
10162: s$arr: # entry point
10163: movl (sp)+,r10 # load initial element value
10164: movl (sp)+,r9 # load first argument
10165: jsb gtint # convert first arg to integer
10166: .long sar02 # jump if not integer
10167: #
10168: # HERE FOR INTEGER FIRST ARGUMENT, BUILD VCBLK
10169: #
10170: movl 4*icval(r9),r5 # load integer value
10171: bgtr 0f # jump if zero or neg (bad dimension)
10172: jmp sar10
10173: 0:
10174: movl r5,r6 # else convert to one word, test ovfl
10175: bgeq 0f
10176: jmp sar11
10177: 0:
10178: movl r6,r7 # copy elements for loop later on
10179: addl2 $vcsi$,r6 # add space for standard fields
10180: moval 0[r6],r6 # convert length to bytes
10181: cmpl r6,mxlen # fail if too large
10182: blssu 0f
10183: jmp sar11
10184: 0:
10185: jsb alloc # allocate space for vcblk
10186: movl $b$vct,(r9) # store type word
10187: movl r6,4*vclen(r9) # set length
10188: movl r10,r8 # copy default value
10189: movl r9,r10 # copy vcblk pointer
10190: addl2 $4*vcvls,r10 # point to first element value
10191: #
10192: # LOOP TO SET VECTOR ELEMENTS TO DEFAULT VALUE
10193: #
10194: sar01: movl r8,(r10)+ # store one value
10195: sobgtr r7,sar01 # loop till all stored
10196: jmp exsid # exit setting idval
10197: #page
10198: #
10199: # ARRAY (CONTINUED)
10200: #
10201: # HERE IF FIRST ARGUMENT IS NOT AN INTEGER
10202: #
10203: sar02: movl r9,-(sp) # replace argument on stack
10204: jsb xscni # initialize scan of first argument
10205: .long er_064 # array first argument is not integer or string
10206: .long exnul # dummy (unused) null string exit
10207: movl r$xsc,-(sp) # save prototype pointer
10208: movl r10,-(sp) # save default value
10209: clrl arcdm # zero count of dimensions
10210: clrl arptr # zero offset to indicate pass one
10211: movl intv1,r5 # load integer one
10212: movl r5,arnel # initialize element count
10213: #
10214: # THE FOLLOWING CODE IS EXECUTED TWICE. THE FIRST TIME
10215: # (ARPTR EQ 0), IT IS USED TO COUNT THE NUMBER OF ELEMENTS
10216: # AND NUMBER OF DIMENSIONS. THE SECOND TIME (ARPTR GT 0) IS
10217: # USED TO ACTUALLY FILL IN THE DIM,LBD FIELDS OF THE ARBLK.
10218: #
10219: sar03: movl intv1,r5 # load one as default low bound
10220: movl r5,arsvl # save as low bound
10221: movl $ch$cl,r8 # set delimiter one = colon
10222: movl $ch$cm,r10 # set delimiter two = comma
10223: jsb xscan # scan next bound
10224: cmpl r6,$num01 # jump if not colon
10225: bnequ sar04
10226: #
10227: # HERE WE HAVE A COLON ENDING A LOW BOUND
10228: #
10229: jsb gtint # convert low bound
10230: .long er_065 # array first argument lower bound is not integer
10231: movl 4*icval(r9),r5 # load value of low bound
10232: movl r5,arsvl # store low bound value
10233: movl $ch$cm,r8 # set delimiter one = comma
10234: movl r8,r10 # and delimiter two = comma
10235: jsb xscan # scan high bound
10236: #page
10237: #
10238: # ARRAY (CONTINUED)
10239: #
10240: # MERGE HERE TO PROCESS UPPER BOUND
10241: #
10242: sar04: jsb gtint # convert high bound to integer
10243: .long er_066 # array first argument upper bound is not integer
10244: movl 4*icval(r9),r5 # get high bound
10245: subl2 arsvl,r5 # subtract lower bound
10246: bvc 0f
10247: jmp sar10
10248: 0:
10249: tstl r5 # bad dimension if negative
10250: bgeq 0f
10251: jmp sar10
10252: 0:
10253: addl2 intv1,r5 # add 1 to get dimension
10254: bvc 0f
10255: jmp sar10
10256: 0:
10257: movl arptr,r10 # load offset (also pass indicator)
10258: beqlu sar05 # jump if first pass
10259: #
10260: # HERE IN SECOND PASS TO STORE LBD AND DIM IN ARBLK
10261: #
10262: addl2 (sp),r10 # point to current location in arblk
10263: movl r5,4*cfp$i(r10) # store dimension
10264: movl arsvl,r5 # load low bound
10265: movl r5,(r10) # store low bound
10266: addl2 $4*ardms,arptr # bump offset to next bounds
10267: jmp sar06 # jump to check for end of bounds
10268: #
10269: # HERE IN PASS 1
10270: #
10271: sar05: incl arcdm # bump dimension count
10272: mull2 arnel,r5 # multiply dimension by count so far
10273: bvc 0f
10274: jmp sar11
10275: 0:
10276: movl r5,arnel # else store updated element count
10277: #
10278: # MERGE HERE AFTER PROCESSING ONE SET OF BOUNDS
10279: #
10280: sar06: tstl r6 # loop back unless end of bounds
10281: beqlu 0f
10282: jmp sar03
10283: 0:
10284: tstl arptr # jump if end of pass 2
10285: beqlu 0f
10286: jmp sar09
10287: 0:
10288: #page
10289: #
10290: # ARRAY (CONTINUED)
10291: #
10292: # HERE AT END OF PASS ONE, BUILD ARBLK
10293: #
10294: movl arnel,r5 # get number of elements
10295: movl r5,r7 # get as addr integer, test ovflo
10296: bgeq 0f
10297: jmp sar11
10298: 0:
10299: moval 0[r7],r7 # else convert to length in bytes
10300: movl $4*arsi$,r6 # set size of standard fields
10301: movl arcdm,r8 # set dimension count to control loop
10302: #
10303: # LOOP TO ALLOW SPACE FOR DIMENSIONS
10304: #
10305: sar07: addl2 $4*ardms,r6 # allow space for one set of bounds
10306: sobgtr r8,sar07 # loop back till all accounted for
10307: movl r6,r10 # save size (=arofs)
10308: #
10309: # NOW ALLOCATE SPACE FOR ARBLK
10310: #
10311: addl2 r7,r6 # add space for elements
10312: addl2 $4,r6 # allow for arpro prototype field
10313: cmpl r6,mxlen # fail if too large
10314: blssu 0f
10315: jmp sar11
10316: 0:
10317: jsb alloc # else allocate arblk
10318: movl (sp),r7 # load default value
10319: movl r9,(sp) # save arblk pointer
10320: movl r6,r8 # save length in bytes
10321: ashl $-2,r6,r6 # convert length back to words
10322: # set counter to control loop
10323: #
10324: # LOOP TO CLEAR ENTIRE ARBLK TO DEFAULT VALUE
10325: #
10326: sar08: movl r7,(r9)+ # set one word
10327: sobgtr r6,sar08 # loop till all set
10328: #page
10329: #
10330: # ARRAY (CONTINUED)
10331: #
10332: # NOW SET INITIAL FIELDS OF ARBLK
10333: #
10334: movl (sp)+,r9 # reload arblk pointer
10335: movl (sp),r7 # load prototype
10336: movl $b$art,(r9) # set type word
10337: movl r8,4*arlen(r9) # store length in bytes
10338: clrl 4*idval(r9) # zero id till we get it built
10339: movl r10,4*arofs(r9) # set prototype field ptr
10340: movl arcdm,4*arndm(r9)# set number of dimensions
10341: movl r9,r8 # save arblk pointer
10342: addl2 r10,r9 # point to prototype field
10343: movl r7,(r9) # store prototype ptr in arblk
10344: movl $4*arlbd,arptr # set offset for pass 2 bounds scan
10345: movl r7,r$xsc # reset string pointer for xscan
10346: movl r8,(sp) # store arblk pointer on stack
10347: clrl xsofs # reset offset ptr to start of string
10348: jmp sar03 # jump back to rescan bounds
10349: #
10350: # HERE AFTER FILLING IN BOUNDS INFORMATION (END PASS TWO)
10351: #
10352: sar09: movl (sp)+,r9 # reload pointer to arblk
10353: jmp exsid # exit setting idval
10354: #
10355: # HERE FOR BAD DIMENSION
10356: #
10357: sar10: jmp er_067 # array dimension is zero,negative or out of range
10358: #
10359: # HERE IF ARRAY IS TOO LARGE
10360: #
10361: sar11: jmp er_068 # array size exceeds maximum permitted
10362: #page
10363: #
10364: # BUFFER
10365: #
10366: s$buf: # entry point
10367: movl (sp)+,r10 # get initial value
10368: movl (sp)+,r9 # get requested allocation
10369: jsb gtint # convert to integer
10370: .long er_269 # buffer first argument is not integer
10371: movl 4*icval(r9),r5 # get value
10372: bleq sbf01 # branch if negative or zero
10373: movl r5,r6 # move with overflow check
10374: bgeq 0f
10375: jmp sbf02
10376: 0:
10377: jsb alobf # allocate the buffer
10378: jsb apndb # copy it in
10379: .long er_270 # buffer second argument is not string or buffer
10380: .long er_271 # buffer initial value too big for allocation
10381: jmp exsid # exit setting idval
10382: #
10383: # HERE FOR INVALID ALLOCATION SIZE
10384: #
10385: sbf01: jmp er_272 # buffer first argument is not positive
10386: #
10387: # HERE FOR ALLOCATION SIZE INTEGER OVERFLOW
10388: #
10389: sbf02: jmp er_273 # buffer size is too big
10390: #page
10391: #
10392: # BREAK
10393: #
10394: s$brk: # entry point
10395: movl $p$bks,r7 # set pcode for single char case
10396: movl $p$brk,r10 # pcode for multi-char case
10397: movl $p$bkd,r8 # pcode for expression case
10398: jsb patst # call common routine to build node
10399: .long er_069 # break argument is not string or expression
10400: jmp exixr # jump for next code word
10401: #page
10402: #
10403: # BREAKX
10404: #
10405: # BREAKX IS A COMPOUND PATTERN. SEE DESCRIPTION AT START
10406: # OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
10407: #
10408: s$bkx: # entry point
10409: movl $p$bks,r7 # pcode for single char argument
10410: movl $p$brk,r10 # pcode for multi-char argument
10411: movl $p$bxd,r8 # pcode for expression case
10412: jsb patst # call common routine to build node
10413: .long er_070 # breakx argument is not string or expression
10414: #
10415: # NOW HOOK BREAKX NODE ON AT FRONT END
10416: #
10417: movl r9,-(sp) # save ptr to break node
10418: movl $p$bkx,r7 # set pcode for breakx node
10419: jsb pbild # build it
10420: movl (sp),4*pthen(r9)# set break node as successor
10421: movl $p$alt,r7 # set pcode for alternation node
10422: jsb pbild # build (parm1=alt=breakx node)
10423: movl r9,r6 # save ptr to alternation node
10424: movl (sp),r9 # point to break node
10425: movl r6,4*pthen(r9) # set alternate node as successor
10426: jmp exits # exit with result on stack
10427: #page
10428: #
10429: # CHAR
10430: #
10431: s$chr: # entry point
10432: jsb gtsmi # convert arg to integer
10433: .long er_281 # char argument not integer
10434: .long schr1 # too big error exit
10435: cmpl r8,$cfp$a # see if out of range of host set
10436: bgequ schr1
10437: movl $num01,r6 # if not set scblk allocation
10438: movl r8,r7 # save char code
10439: jsb alocs # allocate 1 bau scblk
10440: movl r9,r10 # copy scblk pointer
10441: movab cfp$f(r10),r10 # get set to stuff char
10442: movb r7,(r10)+ # stuff it
10443: clrl r10 # clear slop in xl
10444: jmp exixr # exit with scblk pointer
10445: #
10446: # HERE IF CHAR ARGUMENT IS OUT OF RANGE
10447: #
10448: schr1: jmp er_282 # char argument not in range
10449: #page
10450: #
10451: # CLEAR
10452: #
10453: s$clr: # entry point
10454: jsb xscni # initialize to scan argument
10455: .long er_071 # clear argument is not string
10456: .long sclr2 # jump if null
10457: #
10458: # LOOP TO SCAN OUT NAMES IN FIRST ARGUMENT. VARIABLES IN
10459: # THE LIST ARE FALGGED BY SETTING VRGET OF VRBLK TO ZERO.
10460: #
10461: sclr1: movl $ch$cm,r8 # set delimiter one = comma
10462: movl r8,r10 # delimiter two = comma
10463: jsb xscan # scan next variable name
10464: jsb gtnvr # locate vrblk
10465: .long er_072 # clear argument has null variable name
10466: clrl 4*vrget(r9) # else flag by zeroing vrget field
10467: tstl r6 # loop back if stopped by comma
10468: bnequ sclr1
10469: #
10470: # HERE AFTER FLAGGING VARIABLES IN ARGUMENT LIST
10471: #
10472: sclr2: movl hshtb,r7 # point to start of hash table
10473: #
10474: # LOOP THROUGH SLOTS IN HASH TABLE
10475: #
10476: sclr3: cmpl r7,hshte # exit returning null if none left
10477: bnequ 0f
10478: jmp exnul
10479: 0:
10480: movl r7,r9 # else copy slot pointer
10481: addl2 $4,r7 # bump slot pointer
10482: subl2 $4*vrnxt,r9 # set offset to merge into loop
10483: #
10484: # LOOP THROUGH VRBLKS ON ONE HASH CHAIN
10485: #
10486: sclr4: movl 4*vrnxt(r9),r9 # point to next vrblk on chain
10487: beqlu sclr3 # jump for next bucket if chain end
10488: tstl 4*vrget(r9) # jump if not flagged
10489: bnequ sclr5
10490: #page
10491: #
10492: # CLEAR (CONTINUED)
10493: #
10494: # HERE FOR FLAGGED VARIABLE, DO NOT SET VALUE TO NULL
10495: #
10496: jsb setvr # for flagged var, restore vrget
10497: jmp sclr4 # and loop back for next vrblk
10498: #
10499: # HERE TO SET VALUE OF A VARIABLE TO NULL
10500: # PRROTECTED VARIABLES (ARB, ETC) ARE EXEMPT
10501: #
10502: sclr5: cmpl 4*vrsto(r9),$b$vre # check for protected variable (reg05)
10503: beqlu sclr4
10504: movl r9,r10 # copy vrblk pointer (reg05)
10505: #
10506: # LOOP TO LOCATE VALUE AT END OF POSSIBLE TRBLK CHAIN
10507: #
10508: sclr6: movl r10,r6 # save block pointer
10509: movl 4*vrval(r10),r10# load next value field
10510: cmpl (r10),$b$trt # loop back if trapped
10511: beqlu sclr6
10512: #
10513: # NOW STORE THE NULL VALUE
10514: #
10515: movl r6,r10 # restore block pointer
10516: movl $nulls,4*vrval(r10) # store null constant value
10517: jmp sclr4 # loop back for next vrblk
10518: #page
10519: #
10520: # CODE
10521: #
10522: s$cod: # entry point
10523: movl (sp)+,r9 # load argument
10524: jsb gtcod # convert to code
10525: .long exfal # fail if conversion is impossible
10526: jmp exixr # else return code as result
10527: #page
10528: #
10529: # COLLECT
10530: #
10531: s$col: # entry point
10532: movl (sp)+,r9 # load argument
10533: jsb gtint # convert to integer
10534: .long er_073 # collect argument is not integer
10535: movl 4*icval(r9),r5 # load collect argument
10536: movl r5,clsvi # save collect argument
10537: clrl r7 # set no move up
10538: jsb gbcol # perform garbage collection
10539: movl dname,r6 # point to end of memory
10540: subl2 dnamp,r6 # subtract next location
10541: ashl $-2,r6,r6 # convert bytes to words
10542: movl r6,r5 # convert words available as integer
10543: subl2 clsvi,r5 # subtract argument
10544: bvc 0f
10545: jmp exfal
10546: 0:
10547: tstl r5 # fail if not enough
10548: bgeq 0f
10549: jmp exfal
10550: 0:
10551: addl2 clsvi,r5 # else recompute available
10552: jmp exint # and exit with integer result
10553: #page
10554: #
10555: # CONVERT
10556: #
10557: s$cnv: # entry point
10558: jsb gtstg # convert second argument to string
10559: .long er_074 # convert second argument is not string
10560: jsb flstg # fold lower case to upper case
10561: movl (sp),r10 # load first argument
10562: cmpl (r10),$b$pdt # jump if not program defined
10563: bnequ scv01
10564: #
10565: # HERE FOR PROGRAM DEFINED DATATYPE
10566: #
10567: movl 4*pddfp(r10),r10# point to dfblk
10568: movl 4*dfnam(r10),r10# load datatype name
10569: jsb ident # compare with second arg
10570: .long exits # exit if ident with arg as result
10571: jmp exfal # else fail
10572: #
10573: # HERE IF NOT PROGRAM DEFINED DATATYPE
10574: #
10575: scv01: movl r9,-(sp) # save string argument
10576: movl $svctb,r10 # point to table of names to compare
10577: clrl r7 # initialize counter
10578: movl r6,r8 # save length of argument string
10579: #
10580: # LOOP THROUGH TABLE ENTRIES
10581: #
10582: scv02: movl (r10)+,r9 # load next table entry, bump pointer
10583: bnequ 0f # fail if zero marking end of list
10584: jmp exfal
10585: 0:
10586: cmpl r8,4*sclen(r9) # jump if wrong length
10587: beqlu 0f
10588: jmp scv05
10589: 0:
10590: movl r10,cnvtp # else store table pointer
10591: movab cfp$f(r9),r9 # point to chars of table entry
10592: movl (sp),r10 # load pointer to string argument
10593: movab cfp$f(r10),r10 # point to chars of string arg
10594: movl r8,r6 # set number of chars to compare
10595: jsb sbcmc # compare, jump if no match
10596: .long scv04
10597: .long scv04
10598: #page
10599: #
10600: # CONVERT (CONTINUED)
10601: #
10602: # HERE WE HAVE A MATCH
10603: #
10604: scv03: movl r7,r10 # copy entry number
10605: addl2 $4,sp # pop string arg off stack
10606: movl (sp)+,r9 # load first argument
10607: casel r10,$0,$cnvtt # jump to appropriate routine
10608: 5:
10609: .word scv06-5b # string
10610: .word scv07-5b # integer
10611: .word scv09-5b # name
10612: .word scv10-5b # pattern
10613: .word scv11-5b # array
10614: .word scv19-5b # table
10615: .word scv25-5b # expression
10616: .word scv26-5b # code
10617: .word scv27-5b # numeric
10618: .word scv08-5b # real
10619: .word scv28-5b # buffer
10620: #esw # end of switch table
10621: #
10622: # HERE IF NO MATCH WITH TABLE ENTRY
10623: #
10624: scv04: movl cnvtp,r10 # restore table pointer, merge
10625: #
10626: # MERGE HERE IF LENGTHS DID NOT MATCH
10627: #
10628: scv05: incl r7 # bump entry number
10629: jmp scv02 # loop back to check next entry
10630: #
10631: # HERE TO CONVERT TO STRING
10632: #
10633: scv06: movl r9,-(sp) # replace string argument on stack
10634: jsb gtstg # convert to string
10635: .long exfal # fail if conversion not possible
10636: jmp exixr # else return string
10637: #page
10638: #
10639: # CONVERT (CONTINUED)
10640: #
10641: # HERE TO CONVERT TO INTEGER
10642: #
10643: scv07: jsb gtint # convert to integer
10644: .long exfal # fail if conversion not possible
10645: jmp exixr # else return integer
10646: #
10647: # HERE TO CONVERT TO REAL
10648: #
10649: scv08: jsb gtrea # convert to real
10650: .long exfal # fail if conversion not possible
10651: jmp exixr # else return real
10652: #
10653: # HERE TO CONVERT TO NAME
10654: #
10655: scv09: cmpl (r9),$b$nml # return if already a name
10656: bnequ 0f
10657: jmp exixr
10658: 0:
10659: jsb gtnvr # else try string to name convert
10660: .long exfal # fail if conversion not possible
10661: jmp exvnm # else exit building nmblk for vrblk
10662: #
10663: # HERE TO CONVERT TO PATTERN
10664: #
10665: scv10: jsb gtpat # convert to pattern
10666: .long exfal # fail if conversion not possible
10667: jmp exixr # else return pattern
10668: #
10669: # CONVERT TO ARRAY
10670: #
10671: scv11: jsb gtarr # get an array
10672: .long exfal # fail if not convertible
10673: jmp exsid # exit setting id field
10674: #
10675: # CONVERT TO TABLE
10676: #
10677: scv19: movl (r9),r6 # load first word of block
10678: movl r9,-(sp) # replace arblk pointer on stack
10679: cmpl r6,$b$tbt # return arg if already a table
10680: bnequ 0f
10681: jmp exits
10682: 0:
10683: cmpl r6,$b$art # else fail if not an array
10684: beqlu 0f
10685: jmp exfal
10686: 0:
10687: #page
10688: #
10689: # CONVERT (CONTINUED)
10690: #
10691: # HERE TO CONVERT AN ARRAY TO TABLE
10692: #
10693: cmpl 4*arndm(r9),$num02 # fail if not 2-dim array
10694: beqlu 0f
10695: jmp exfal
10696: 0:
10697: movl 4*ardm2(r9),r5 # load dim 2
10698: subl2 intv2,r5 # subtract 2 to compare
10699: beql 0f # fail if dim2 not 2
10700: jmp exfal
10701: 0:
10702: #
10703: # HERE WE HAVE AN ARBLK OF THE RIGHT SHAPE
10704: #
10705: movl 4*ardim(r9),r5 # load dim 1 (number of elements)
10706: movl r5,r6 # get as one word integer
10707: movl r6,r7 # copy to control loop
10708: addl2 $tbsi$,r6 # add space for standard fields
10709: moval 0[r6],r6 # convert length to bytes
10710: jsb alloc # allocate space for tbblk
10711: movl r9,r8 # copy tbblk pointer
10712: movl r9,-(sp) # save tbblk pointer
10713: movl $b$tbt,(r9)+ # store type word
10714: clrl (r9)+ # store zero for idval for now
10715: movl r6,(r9)+ # store length
10716: movl $nulls,(r9)+ # null initial lookup value
10717: #
10718: # LOOP TO INITIALIZE BUCKET PTRS TO POINT TO TABLE
10719: #
10720: scv20: movl r8,(r9)+ # set bucket ptr to point to tbblk
10721: sobgtr r7,scv20 # loop till all initialized
10722: movl $4*arvl2,r7 # set offset to first arblk element
10723: #
10724: # LOOP TO COPY ELEMENTS FROM ARRAY TO TABLE
10725: #
10726: scv21: movl 4*1(sp),r10 # point to arblk
10727: cmpl r7,4*arlen(r10) # jump if all moved
10728: beqlu scv24
10729: addl2 r7,r10 # else point to current location
10730: addl2 $4*num02,r7 # bump offset
10731: movl (r10),r9 # load subscript name
10732: subl2 $4,r10 # adjust ptr to merge (trval=1+1)
10733: #page
10734: #
10735: # CONVERT (CONTINUED)
10736: #
10737: # LOOP TO CHASE DOWN TRBLK CHAIN FOR VALUE
10738: #
10739: scv22: movl 4*trval(r10),r10# point to next value
10740: cmpl (r10),$b$trt # loop back if trapped
10741: beqlu scv22
10742: #
10743: # HERE WITH NAME IN XR, VALUE IN XL
10744: #
10745: scv23: movl r10,-(sp) # stack value
10746: movl 4*1(sp),r10 # load tbblk pointer
10747: jsb tfind # build teblk (note wb gt 0 by name)
10748: .long exfal # fail if acess fails
10749: movl (sp)+,4*teval(r10) # store value in teblk
10750: jmp scv21 # loop back for next element
10751: #
10752: # HERE AFTER MOVING ALL ELEMENTS TO TBBLK
10753: #
10754: scv24: movl (sp)+,r9 # load tbblk pointer
10755: addl2 $4,sp # pop arblk pointer
10756: jmp exsid # exit setting idval
10757: #
10758: # CONVERT TO EXPRESSION
10759: #
10760: scv25: jsb gtexp # convert to expression
10761: .long exfal # fail if conversion not possible
10762: jmp exixr # else return expression
10763: #
10764: # CONVERT TO CODE
10765: #
10766: scv26: jsb gtcod # convert to code
10767: .long exfal # fail if conversion is not possible
10768: jmp exixr # else return code
10769: #
10770: # CONVERT TO NUMERIC
10771: #
10772: scv27: jsb gtnum # convert to numeric
10773: .long exfal # fail if unconvertible
10774: jmp exixr # return number
10775: #page
10776: #
10777: # CONVERT TO BUFFER
10778: #
10779: scv28: movl r9,-(sp) # stack string for procedure
10780: jsb gtstg # convert to string
10781: .long exfal # fail if conversion not possible
10782: movl r9,r10 # save string pointer
10783: jsb alobf # allocate buffer of same size
10784: jsb apndb # copy in the string
10785: .long invalid$ # already string - cant fail to cnv
10786: .long invalid$ # must be enough room
10787: jmp exsid # exit setting idval field
10788: #page
10789: #
10790: # COPY
10791: #
10792: s$cop: # entry point
10793: jsb copyb # copy the block
10794: .long exits # return if no idval field
10795: jmp exsid # exit setting id value
10796: #page
10797: #
10798: # DATA
10799: #
10800: s$dat: # entry point
10801: jsb xscni # prepare to scan argument
10802: .long er_075 # data argument is not string
10803: .long er_076 # data argument is null
10804: #
10805: # SCAN OUT DATATYPE NAME
10806: #
10807: movl $ch$pp,r8 # delimiter one = left paren
10808: movl r8,r10 # delimiter two = left paren
10809: jsb xscan # scan datatype name
10810: tstl r6 # skip if left paren found
10811: bnequ sdat1
10812: jmp er_077 # data argument is missing a left paren
10813: #
10814: # HERE AFTER SCANNING DATATYPE NAME
10815: #
10816: sdat1: movl 4*sclen(r9),r6 # get length
10817: jsb flstg # fold lower case to upper case
10818: movl r9,r10 # save name ptr
10819: movl 4*sclen(r9),r6 # get length
10820: movab 3+(4*scsi$)(r6),r6 # compute space needed
10821: bicl2 $3,r6
10822: jsb alost # request static store for name
10823: movl r9,-(sp) # save datatype name
10824: jsb sbmvw # copy name to static
10825: movl (sp),r9 # get name ptr
10826: clrl r10 # scrub dud register
10827: jsb gtnvr # locate vrblk for datatype name
10828: .long er_078 # data argument has null datatype name
10829: movl r9,datdv # save vrblk pointer for datatype
10830: movl sp,datxs # store starting stack value
10831: clrl r7 # zero count of field names
10832: #
10833: # LOOP TO SCAN FIELD NAMES AND STACK VRBLK POINTERS
10834: #
10835: sdat2: movl $ch$rp,r8 # delimiter one = right paren
10836: movl $ch$cm,r10 # delimiter two = comma
10837: jsb xscan # scan next field name
10838: tstl r6 # jump if delimiter found
10839: bnequ sdat3
10840: jmp er_079 # data argument is missing a right paren
10841: #
10842: # HERE AFTER SCANNING OUT ONE FIELD NAME
10843: #
10844: sdat3: jsb gtnvr # locate vrblk for field name
10845: .long er_080 # data argument has null field name
10846: movl r9,-(sp) # stack vrblk pointer
10847: incl r7 # increment counter
10848: cmpl r6,$num02 # loop back if stopped by comma
10849: beqlu sdat2
10850: #page
10851: #
10852: # DATA (CONTINUED)
10853: #
10854: # NOW BUILD THE DFBLK
10855: #
10856: movl $dfsi$,r6 # set size of dfblk standard fields
10857: addl2 r7,r6 # add number of fields
10858: moval 0[r6],r6 # convert length to bytes
10859: movl r7,r8 # preserve no. of fields
10860: jsb alost # allocate space for dfblk
10861: movl r8,r7 # get no of fields
10862: movl datxs,r10 # point to start of stack
10863: movl (r10),r8 # load datatype name
10864: movl r9,(r10) # save dfblk pointer on stack
10865: movl $b$dfc,(r9)+ # store type word
10866: movl r7,(r9)+ # store number of fields (fargs)
10867: movl r6,(r9)+ # store length (dflen)
10868: subl2 $4*pddfs,r6 # compute pdblk length (for dfpdl)
10869: movl r6,(r9)+ # store pdblk length (dfpdl)
10870: movl r8,(r9)+ # store datatype name (dfnam)
10871: movl r7,r8 # copy number of fields
10872: #
10873: # LOOP TO MOVE FIELD NAME VRBLK POINTERS TO DFBLK
10874: #
10875: sdat4: movl -(r10),(r9)+ # move one field name vrblk pointer
10876: sobgtr r8,sdat4 # loop till all moved
10877: #
10878: # NOW DEFINE THE DATATYPE FUNCTION
10879: #
10880: movl r6,r8 # copy length of pdblk for later loop
10881: movl datdv,r9 # point to vrblk
10882: movl datxs,r10 # point back on stack
10883: movl (r10),r10 # load dfblk pointer
10884: jsb dffnc # define function
10885: #page
10886: #
10887: # DATA (CONTINUED)
10888: #
10889: # LOOP TO BUILD FFBLKS
10890: #
10891: #
10892: # NOTICE THAT THE FFBLKS ARE CONSTRUCTED IN REVERSE ORDER
10893: # SO THAT THE REQUIRED OFFSETS CAN BE OBTAINED FROM
10894: # SUCCESSIVE DECREMENTATION OF THE PDBLK LENGTH (IN WC).
10895: #
10896: sdat5: movl $4*ffsi$,r6 # set length of ffblk
10897: jsb alloc # allocate space for ffblk
10898: movl $b$ffc,(r9) # set type word
10899: movl $num01,4*fargs(r9) # store fargs (always one)
10900: movl datxs,r10 # point back on stack
10901: movl (r10),4*ffdfp(r9)# copy dfblk ptr to ffblk
10902: subl2 $4,r8 # decrement old dfpdl to get next ofs
10903: movl r8,4*ffofs(r9) # set offset to this field
10904: clrl 4*ffnxt(r9) # tentatively set zero forward ptr
10905: movl r9,r10 # copy ffblk pointer for dffnc
10906: movl (sp),r9 # load vrblk pointer for field
10907: movl 4*vrfnc(r9),r9 # load current function pointer
10908: cmpl (r9),$b$ffc # skip if not currently a field func
10909: bnequ sdat6
10910: #
10911: # HERE WE MUST CHAIN AN OLD FFBLK PTR TO PRESERVE IT IN THE
10912: # CASE OF MULTIPLE FIELD FUNCTIONS WITH THE SAME NAME
10913: #
10914: movl r9,4*ffnxt(r10) # link new ffblk to previous chain
10915: #
10916: # MERGE HERE TO DEFINE FIELD FUNCTION
10917: #
10918: sdat6: movl (sp)+,r9 # load vrblk pointer
10919: jsb dffnc # define field function
10920: cmpl sp,datxs # loop back till all done
10921: bnequ sdat5
10922: addl2 $4,sp # pop dfblk pointer
10923: jmp exnul # return with null result
10924: #page
10925: #
10926: # DATATYPE
10927: #
10928: s$dtp: # entry point
10929: movl (sp)+,r9 # load argument
10930: jsb dtype # get datatype
10931: jmp exixr # and return it as result
10932: #page
10933: #
10934: # DATE
10935: #
10936: s$dte: # entry point
10937: jsb sysdt # call system date routine
10938: movl 4*1(r10),r6 # load length for sbstr
10939: bnequ 0f # return null if length is zero
10940: jmp exnul
10941: 0:
10942: clrl r7 # set zero offset
10943: jsb sbstr # use sbstr to build scblk
10944: jmp exixr # return date string
10945: #page
10946: #
10947: # DEFINE
10948: #
10949: s$def: # entry point
10950: movl (sp)+,r9 # load second argument
10951: clrl deflb # zero label pointer in case null
10952: cmpl r9,$nulls # jump if null second argument
10953: beqlu sdf01
10954: jsb gtnvr # else find vrblk for label
10955: .long sdf13 # jump if not a variable name
10956: movl r9,deflb # else set specified entry
10957: #
10958: # SCAN FUNCTION NAME
10959: #
10960: sdf01: jsb xscni # prepare to scan first argument
10961: .long er_081 # define first argument is not string
10962: .long er_082 # define first argument is null
10963: movl $ch$pp,r8 # delimiter one = left paren
10964: movl r8,r10 # delimiter two = left paren
10965: jsb xscan # scan out function name
10966: tstl r6 # jump if left paren found
10967: bnequ sdf02
10968: jmp er_083 # define first argument is missing a left paren
10969: #
10970: # HERE AFTER SCANNING OUT FUNCTION NAME
10971: #
10972: sdf02: jsb gtnvr # get variable name
10973: .long er_084 # define first argument has null function name
10974: movl r9,defvr # save vrblk pointer for function nam
10975: clrl r7 # zero count of arguments
10976: movl sp,defxs # save initial stack pointer
10977: tstl deflb # jump if second argument given
10978: bnequ sdf03
10979: movl r9,deflb # else default is function name
10980: #
10981: # LOOP TO SCAN ARGUMENT NAMES AND STACK VRBLK POINTERS
10982: #
10983: sdf03: movl $ch$rp,r8 # delimiter one = right paren
10984: movl $ch$cm,r10 # delimiter two = comma
10985: jsb xscan # scan out next argument name
10986: tstl r6 # skip if delimiter found
10987: bnequ sdf04
10988: jmp er_085 # null arg name or missing ) in define first arg.
10989: #page
10990: #
10991: # DEFINE (CONTINUED)
10992: #
10993: # HERE AFTER SCANNING AN ARGUMENT NAME
10994: #
10995: sdf04: cmpl r9,$nulls # skip if non-null
10996: bnequ sdf05
10997: tstl r7 # ignore null if case of no arguments
10998: beqlu sdf06
10999: #
11000: # HERE AFTER DEALING WITH THE CASE OF NO ARGUMENTS
11001: #
11002: sdf05: jsb gtnvr # get vrblk pointer
11003: .long sdf03 # loop back to ignore null name
11004: movl r9,-(sp) # stack argument vrblk pointer
11005: incl r7 # increment counter
11006: cmpl r6,$num02 # loop back if stopped by a comma
11007: beqlu sdf03
11008: #
11009: # HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES
11010: #
11011: sdf06: movl r7,defna # save number of arguments
11012: clrl r7 # zero count of locals
11013: #
11014: # LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS
11015: #
11016: sdf07: movl $ch$cm,r8 # set delimiter one = comma
11017: movl r8,r10 # set delimiter two = comma
11018: jsb xscan # scan out next local name
11019: cmpl r9,$nulls # skip if non-null
11020: bnequ sdf08
11021: tstl r7 # ignore null if case of no locals
11022: beqlu sdf09
11023: #
11024: # HERE AFTER SCANNING OUT A LOCAL NAME
11025: #
11026: sdf08: jsb gtnvr # get vrblk pointer
11027: .long sdf07 # loop back to ignore null name
11028: incl r7 # if ok, increment count
11029: movl r9,-(sp) # stack vrblk pointer
11030: tstl r6 # loop back if stopped by a comma
11031: bnequ sdf07
11032: #page
11033: #
11034: # DEFINE (CONTINUED)
11035: #
11036: # HERE AFTER SCANNING LOCALS, BUILD PFBLK
11037: #
11038: sdf09: movl r7,r6 # copy count of locals
11039: addl2 defna,r6 # add number of arguments
11040: movl r6,r8 # set sum args+locals as loop count
11041: addl2 $pfsi$,r6 # add space for standard fields
11042: moval 0[r6],r6 # convert length to bytes
11043: jsb alloc # allocate space for pfblk
11044: movl r9,r10 # save pointer to pfblk
11045: movl $b$pfc,(r9)+ # store first word
11046: movl defna,(r9)+ # store number of arguments
11047: movl r6,(r9)+ # store length (pflen)
11048: movl defvr,(r9)+ # store vrblk ptr for function name
11049: movl r7,(r9)+ # store number of locals
11050: clrl (r9)+ # deal with label later
11051: clrl (r9)+ # zero pfctr
11052: clrl (r9)+ # zero pfrtr
11053: tstl r8 # skip if no args or locals
11054: beqlu sdf11
11055: movl r10,r6 # keep pfblk pointer
11056: movl defxs,r10 # point before arguments
11057: # get count of args+locals for loop
11058: #
11059: # LOOP TO MOVE LOCALS AND ARGS TO PFBLK
11060: #
11061: sdf10: movl -(r10),(r9)+ # store one entry and bump pointers
11062: sobgtr r8,sdf10 # loop till all stored
11063: movl r6,r10 # recover pfblk pointer
11064: #page
11065: #
11066: # DEFINE (CONTINUED)
11067: #
11068: # NOW DEAL WITH LABEL
11069: #
11070: sdf11: movl defxs,sp # pop stack
11071: movl deflb,r9 # point to vrblk for label
11072: movl 4*vrlbl(r9),r9 # load label pointer
11073: cmpl (r9),$b$trt # skip if not trapped
11074: bnequ sdf12
11075: movl 4*trlbl(r9),r9 # else point to real label
11076: #
11077: # HERE AFTER LOCATING REAL LABEL POINTER
11078: #
11079: sdf12: cmpl r9,$stndl # jump if label is not defined
11080: beqlu sdf13
11081: movl r9,4*pfcod(r10) # else store label pointer
11082: movl defvr,r9 # point back to vrblk for function
11083: jsb dffnc # define function
11084: jmp exnul # and exit returning null
11085: #
11086: # HERE FOR ERRONEOUS LABEL
11087: #
11088: sdf13: jmp er_086 # define function entry point is not defined label
11089: #page
11090: #
11091: # DETACH
11092: #
11093: s$det: # entry point
11094: movl (sp)+,r9 # load argument
11095: jsb gtvar # locate variable
11096: .long er_087 # detach argument is not appropriate name
11097: jsb dtach # detach i/o association from name
11098: jmp exnul # return null result
11099: #page
11100: #
11101: # DIFFER
11102: #
11103: s$dif: # entry point
11104: movl (sp)+,r9 # load second argument
11105: movl (sp)+,r10 # load first argument
11106: jsb ident # call ident comparison routine
11107: .long exfal # fail if ident
11108: jmp exnul # return null if differ
11109: #page
11110: #
11111: # DUMP
11112: #
11113: s$dmp: # entry point
11114: jsb gtsmi # load dump arg as small integer
11115: .long er_088 # dump argument is not integer
11116: .long er_089 # dump argument is negative or too large
11117: jsb dumpr # else call dump routine
11118: jmp exnul # and return null as result
11119: #page
11120: #
11121: # DUPL
11122: #
11123: s$dup: # entry point
11124: jsb gtsmi # get second argument as small intege
11125: .long er_090 # dupl second argument is not integer
11126: .long sdup7 # jump if negative ot too big
11127: movl r9,r7 # save duplication factor
11128: jsb gtstg # get first arg as string
11129: .long sdup4 # jump if not a string
11130: #
11131: # HERE FOR CASE OF DUPLICATION OF A STRING
11132: #
11133: movl r6,r5 # acquire length as integer
11134: movl r5,dupsi # save for the moment
11135: movl r7,r5 # get duplication factor as integer
11136: mull2 dupsi,r5 # form product
11137: bvs sdup3
11138: tstl r5 # return null if result length = 0
11139: bneq 0f
11140: jmp exnul
11141: 0:
11142: movl r5,r6 # get as addr integer, check ovflo
11143: bgeq 0f
11144: jmp sdup3
11145: 0:
11146: #
11147: # MERGE HERE WITH RESULT LENGTH IN WA
11148: #
11149: sdup1: movl r9,r10 # save string pointer
11150: jsb alocs # allocate space for string
11151: movl r9,-(sp) # save as result pointer
11152: movl r10,r8 # save pointer to argument string
11153: movab cfp$f(r9),r9 # prepare to store chars of result
11154: # set counter to control loop
11155: #
11156: # LOOP THROUGH DUPLICATIONS
11157: #
11158: sdup2: movl r8,r10 # point back to argument string
11159: movl 4*sclen(r10),r6 # get number of characters
11160: movab cfp$f(r10),r10 # point to chars in argument string
11161: jsb sbmvc # move characters to result string
11162: sobgtr r7,sdup2 # loop till all duplications done
11163: jmp exits # then exit for next code word
11164: #page
11165: #
11166: # DUPL (CONTINUED)
11167: #
11168: # HERE IF TOO LARGE, SET MAX LENGTH AND LET ALOCS CATCH IT
11169: #
11170: sdup3: movl dname,r6 # set impossible length for alocs
11171: jmp sdup1 # merge back
11172: #
11173: # HERE IF NOT A STRING
11174: #
11175: sdup4: jsb gtpat # convert argument to pattern
11176: .long er_091 # dupl first argument is not string or pattern
11177: #
11178: # HERE TO DUPLICATE A PATTERN ARGUMENT
11179: #
11180: movl r9,-(sp) # store pattern on stack
11181: movl $ndnth,r9 # start off with null pattern
11182: tstl r7 # null pattern is result if dupfac=0
11183: beqlu sdup6
11184: movl r7,-(sp) # preserve loop count
11185: #
11186: # LOOP TO DUPLICATE BY SUCCESSIVE CONCATENATION
11187: #
11188: sdup5: movl r9,r10 # copy current value as right argumnt
11189: movl 4*1(sp),r9 # get a new copy of left
11190: jsb pconc # concatenate
11191: decl (sp) # count down
11192: bnequ sdup5 # loop
11193: addl2 $4,sp # pop loop count
11194: #
11195: # HERE TO EXIT AFTER CONSTRUCTING PATTERN
11196: #
11197: sdup6: movl r9,(sp) # store result on stack
11198: jmp exits # exit with result on stack
11199: #
11200: # FAIL IF SECOND ARG IS OUT OF RANGE
11201: #
11202: sdup7: addl2 $4,sp # pop first argument
11203: jmp exfal # fail
11204: #page
11205: #
11206: # EJECT
11207: #
11208: s$ejc: # entry point
11209: jsb iofcb # call fcblk routine
11210: .long er_092 # eject argument is not a suitable name
11211: .long sejc1 # null argument
11212: jsb sysef # call eject file function
11213: .long er_093 # eject file does not exist
11214: .long er_094 # eject file does not permit page eject
11215: .long er_095 # eject caused non-recoverable output error
11216: jmp exnul # return null as result
11217: #
11218: # HERE TO EJECT STANDARD OUTPUT FILE
11219: #
11220: sejc1: jsb sysep # call routine to eject printer
11221: jmp exnul # exit with null result
11222: #page
11223: #
11224: # ENDFILE
11225: #
11226: s$enf: # entry point
11227: jsb iofcb # call fcblk routine
11228: .long er_096 # endfile argument is not a suitable name
11229: .long er_097 # endfile argument is null
11230: jsb sysen # call endfile routine
11231: .long er_098 # endfile file does not exist
11232: .long er_099 # endfile file does not permit endfile
11233: .long er_100 # endfile caused non-recoverable output error
11234: movl r10,r7 # remember vrblk ptr from iofcb call
11235: #
11236: # LOOP TO FIND TRTRF BLOCK
11237: #
11238: senf1: movl r10,r9 # copy pointer
11239: movl 4*trval(r9),r9 # chain along
11240: cmpl (r9),$b$trt # skip out if chain end
11241: beqlu 0f
11242: jmp exnul
11243: 0:
11244: cmpl 4*trtyp(r9),$trtfc # loop if not found
11245: bnequ senf1
11246: movl 4*trval(r9),4*trval(r10) # remove trtrf
11247: movl 4*trtrf(r9),enfch# point to head of iochn
11248: movl 4*trfpt(r9),r8 # point to fcblk
11249: movl r7,r9 # filearg1 vrblk from iofcb
11250: jsb setvr # reset it
11251: movl $r$fcb,r10 # ptr to head of fcblk chain
11252: subl2 $4*num02,r10 # adjust ready to enter loop
11253: #
11254: # FIND FCBLK
11255: #
11256: senf2: movl r10,r9 # copy ptr
11257: movl 4*2(r10),r10 # get next link
11258: beqlu senf4 # stop if chain end
11259: cmpl 4*3(r10),r8 # jump if fcblk found
11260: beqlu senf3
11261: jmp senf2 # loop
11262: #
11263: # REMOVE FCBLK
11264: #
11265: senf3: movl 4*2(r10),4*2(r9)# delete fcblk from chain
11266: #
11267: # LOOP WHICH DETACHES ALL VBLS ON IOCHN CHAIN
11268: #
11269: senf4: movl enfch,r10 # get chain head
11270: bnequ 0f # finished if chain end
11271: jmp exnul
11272: 0:
11273: movl 4*trtrf(r10),enfch # chain along
11274: movl 4*ionmo(r10),r6 # name offset
11275: movl 4*ionmb(r10),r10# name base
11276: jsb dtach # detach name
11277: jmp senf4 # loop till done
11278: #page
11279: #
11280: # EQ
11281: #
11282: s$eqf: # entry point
11283: jsb acomp # call arithmetic comparison routine
11284: .long er_101 # eq first argument is not numeric
11285: .long er_102 # eq second argument is not numeric
11286: .long exfal # fail if lt
11287: .long exnul # return null if eq
11288: .long exfal # fail if gt
11289: #page
11290: #
11291: # EVAL
11292: #
11293: s$evl: # entry point
11294: movl (sp)+,r9 # load argument
11295: jsb gtexp # convert to expression
11296: .long er_103 # eval argument is not expression
11297: movl (r3)+,r8 # load next code word
11298: cmpl r8,$ofne$ # jump if called by value
11299: bnequ sevl1
11300: movl r3,r10 # copy code pointer
11301: movl (r10),r6 # get next code word
11302: cmpl r6,$ornm$ # by name unless expression
11303: bnequ sevl2
11304: tstl 4*1(sp) # jump if by name
11305: bnequ sevl2
11306: #
11307: # HERE IF CALLED BY VALUE
11308: #
11309: sevl1: clrl r7 # set flag for by value
11310: movl r8,-(sp) # save code word
11311: jsb evalx # evaluate expression by value
11312: .long exfal # fail if evaluation fails
11313: movl r9,r10 # copy result
11314: movl (sp),r9 # reload next code word
11315: movl r10,(sp) # stack result
11316: movl (r9),r11 # jump to execute next code word
11317: jmp (r11)
11318: #
11319: # HERE IF CALLED BY NAME
11320: #
11321: sevl2: movl $num01,r7 # set flag for by name
11322: jsb evalx # evaluate expression by name
11323: .long exfal # fail if evaluation fails
11324: jmp exnam # exit with name
11325: #page
11326: #
11327: # EXIT
11328: #
11329: s$ext: # entry point
11330: clrl r7 # clear amount of static shift
11331: jsb gbcol # compact memory by collecting
11332: jsb gtstg # convert arg to string
11333: .long er_104 # exit argument is not suitable integer or string
11334: movl r9,r10 # copy string ptr
11335: jsb gtint # check it is integer
11336: .long sext1 # skip if unconvertible
11337: clrl r10 # note it is integer
11338: movl 4*icval(r9),r5 # get integer arg
11339: movl r$fcb,r7 # get fcblk chain header
11340: #
11341: # MERGE TO CALL OSINT EXIT ROUTINE
11342: #
11343: sext1: movl $headv,r9 # point to v.v string
11344: jsb sysxi # call external routine
11345: .long er_105 # exit action not available in this implementation
11346: .long er_106 # exit action caused irrecoverable error
11347: tstl r5 # return if argument 0
11348: bneq 0f
11349: jmp exnul
11350: 0:
11351: clrl gbcnt # resuming execution so reset
11352: tstl r5 # skip if positive
11353: bgtr sext2
11354: mnegl r5,r5 # make positive
11355: #
11356: # CHECK FOR OPTION RESPECIFICATION
11357: #
11358: sext2: movl r5,r8 # get value in work reg
11359: cmpl r8,$num03 # skip if was 3
11360: beqlu sext3
11361: movl r8,-(sp) # save value
11362: clrl r8 # set to read options
11363: jsb prpar # read syspp options
11364: movl (sp)+,r8 # restore value
11365: #
11366: # DEAL WITH HEADER OPTION (FIDDLED BY PRPAR)
11367: #
11368: sext3: movl sp,headp # assume no headers
11369: cmpl r8,$num01 # skip if not 1
11370: bnequ sext4
11371: clrl headp # request header printing
11372: #
11373: # ALMOST READY TO RESUME RUNNING
11374: #
11375: sext4: jsb systm # get execution time start (sgd11)
11376: movl r5,timsx # save as initial time
11377: movl kvstc,r5 # reset to ensure ...
11378: movl r5,kvstl # ... correct execution stats
11379: jmp exnul # resume execution
11380: #page
11381: #
11382: # FIELD
11383: #
11384: s$fld: # entry point
11385: jsb gtsmi # get second argument (field number)
11386: .long er_107 # field second argument is not integer
11387: .long exfal # fail if out of range
11388: movl r9,r7 # else save integer value
11389: movl (sp)+,r9 # load first argument
11390: jsb gtnvr # point to vrblk
11391: .long sfld1 # jump (error) if not variable name
11392: movl 4*vrfnc(r9),r9 # else point to function block
11393: cmpl (r9),$b$dfc # error if not datatype function
11394: bnequ sfld1
11395: #
11396: # HERE IF FIRST ARGUMENT IS A DATATYPE FUNCTION NAME
11397: #
11398: tstl r7 # fail if argument number is zero
11399: bnequ 0f
11400: jmp exfal
11401: 0:
11402: cmpl r7,4*fargs(r9) # fail if too large
11403: blequ 0f
11404: jmp exfal
11405: 0:
11406: moval 0[r7],r7 # else convert to byte offset
11407: addl2 r7,r9 # point to field name
11408: movl 4*dfflb(r9),r9 # load vrblk pointer
11409: jmp exvnm # exit to build nmblk
11410: #
11411: # HERE FOR BAD FIRST ARGUMENT
11412: #
11413: sfld1: jmp er_108 # field first argument is not datatype name
11414: #page
11415: #
11416: # FENCE
11417: #
11418: s$fnc: # entry point
11419: movl $p$fnc,r7 # set pcode for p$fnc
11420: clrl r9 # p0blk
11421: jsb pbild # build p$fnc node
11422: movl r9,r10 # save pointer to it
11423: movl (sp)+,r9 # get argument
11424: jsb gtpat # convert to pattern
11425: .long er_259 # fence argument is not pattern
11426: jsb pconc # concatenate to p$fnc node
11427: movl r9,r10 # save ptr to concatenated pattern
11428: movl $p$fna,r7 # set for p$fna pcode
11429: clrl r9 # p0blk
11430: jsb pbild # construct p$fna node
11431: movl r10,4*pthen(r9) # set pattern as pthen
11432: movl r9,-(sp) # set as result
11433: jmp exits # do next code word
11434: #page
11435: #
11436: # GE
11437: #
11438: s$gef: # entry point
11439: jsb acomp # call arithmetic comparison routine
11440: .long er_109 # ge first argument is not numeric
11441: .long er_110 # ge second argument is not numeric
11442: .long exfal # fail if lt
11443: .long exnul # return null if eq
11444: .long exnul # return null if gt
11445: #page
11446: #
11447: # GT
11448: #
11449: s$gtf: # entry point
11450: jsb acomp # call arithmetic comparison routine
11451: .long er_111 # gt first argument is not numeric
11452: .long er_112 # gt second argument is not numeric
11453: .long exfal # fail if lt
11454: .long exfal # fail if eq
11455: .long exnul # return null if gt
11456: #page
11457: #
11458: # HOST
11459: #
11460: s$hst: # entry point
11461: movl (sp)+,r9 # get third arg
11462: movl (sp)+,r10 # get second arg
11463: movl (sp)+,r6 # get first arg
11464: jsb syshs # enter syshs routine
11465: .long er_254 # erroneous argument for host
11466: .long er_255 # error during execution of host
11467: .long shst1 # store host string
11468: .long exnul # return null result
11469: .long exixr # return xr
11470: .long exfal # fail return
11471: #
11472: # RETURN HOST STRING
11473: #
11474: shst1: tstl r10 # null string if syshs uncooperative
11475: bnequ 0f
11476: jmp exnul
11477: 0:
11478: movl 4*sclen(r10),r6 # length
11479: clrl r7 # zero offset
11480: jsb sbstr # build copy of string
11481: movl r9,-(sp) # stack the result
11482: jmp exits # return result on stack
11483: #page
11484: #
11485: # IDENT
11486: #
11487: s$idn: # entry point
11488: movl (sp)+,r9 # load second argument
11489: movl (sp)+,r10 # load first argument
11490: jsb ident # call ident comparison routine
11491: .long exnul # return null if ident
11492: jmp exfal # fail if differ
11493: #page
11494: #
11495: # INPUT
11496: #
11497: s$inp: # entry point
11498: clrl r7 # input flag
11499: jsb ioput # call input/output assoc. routine
11500: .long er_113 # input third argument is not a string
11501: .long er_114 # inappropriate second argument for input
11502: .long er_115 # inappropriate first argument for input
11503: .long er_116 # inappropriate file specification for input
11504: .long exfal # fail if file does not exist
11505: .long er_117 # input file cannot be read
11506: jmp exnul # return null string
11507: #page
11508: #
11509: # INSERT
11510: #
11511: s$ins: # entry point
11512: movl (sp)+,r10 # get string arg
11513: jsb gtsmi # get replace length
11514: .long er_277 # insert third argument not integer
11515: .long exfal # fail if out of range
11516: movl r8,r7 # copy to proper reg
11517: jsb gtsmi # get replace position
11518: .long er_278 # insert second argument not integer
11519: .long exfal # fail if out of range
11520: tstl r8 # fail if zero
11521: bnequ 0f
11522: jmp exfal
11523: 0:
11524: decl r8 # decrement to get offset
11525: movl r8,r6 # put in proper register
11526: movl (sp)+,r9 # get buffer
11527: cmpl (r9),$b$bct # press on if type ok
11528: beqlu sins1
11529: jmp er_279 # insert first argument not buffer
11530: #
11531: # HERE WHEN EVERYTHING LOADED UP
11532: #
11533: sins1: jsb insbf # call to insert
11534: .long er_280 # insert fourth argument not a string
11535: .long exfal # fail if out of range
11536: jmp exnul # else ok - exit with null
11537: #page
11538: #
11539: # INTEGER
11540: #
11541: s$int: # entry point
11542: movl (sp)+,r9 # load argument
11543: jsb gtnum # convert to numeric
11544: .long exfal # fail if non-numeric
11545: cmpl r6,$b$icl # return null if integer
11546: bnequ 0f
11547: jmp exnul
11548: 0:
11549: jmp exfal # fail if real
11550: #page
11551: #
11552: # ITEM
11553: #
11554: # ITEM DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
11555: # WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
11556: #
11557: s$itm: # entry point
11558: #
11559: # DEAL WITH CASE OF NO ARGS
11560: #
11561: tstl r6 # jump if at least one arg
11562: bnequ sitm1
11563: movl $nulls,-(sp) # else supply garbage null arg
11564: movl $num01,r6 # and fix argument count
11565: #
11566: # CHECK FOR NAME/VALUE CASES
11567: #
11568: sitm1: movl r3,r9 # get current code pointer
11569: movl (r9),r10 # load next code word
11570: decl r6 # get number of subscripts
11571: movl r6,r9 # copy for arref
11572: cmpl r10,$ofne$ # jump if called by name
11573: beqlu sitm2
11574: #
11575: # HERE IF CALLED BY VALUE
11576: #
11577: clrl r7 # set code for call by value
11578: jmp arref # off to array reference routine
11579: #
11580: # HERE FOR CALL BY NAME
11581: #
11582: sitm2: movl sp,r7 # set code for call by name
11583: movl (r3)+,r6 # load and ignore ofne$ call
11584: jmp arref # off to array reference routine
11585: #page
11586: #
11587: # LE
11588: #
11589: s$lef: # entry point
11590: jsb acomp # call arithmetic comparison routine
11591: .long er_118 # le first argument is not numeric
11592: .long er_119 # le second argument is not numeric
11593: .long exnul # return null if lt
11594: .long exnul # return null if eq
11595: .long exfal # fail if gt
11596: #page
11597: #
11598: # LEN
11599: #
11600: s$len: # entry point
11601: movl $p$len,r7 # set pcode for integer arg case
11602: movl $p$lnd,r6 # set pcode for expr arg case
11603: jsb patin # call common routine to build node
11604: .long er_120 # len argument is not integer or expression
11605: .long er_121 # len argument is negative or too large
11606: jmp exixr # return pattern node
11607: #page
11608: #
11609: # LEQ
11610: #
11611: s$leq: # entry point
11612: jsb lcomp # call string comparison routine
11613: .long er_122 # leq first argument is not string
11614: .long er_123 # leq second argument is not string
11615: .long exfal # fail if llt
11616: .long exnul # return null if leq
11617: .long exfal # fail if lgt
11618: #page
11619: #
11620: # LGE
11621: #
11622: s$lge: # entry point
11623: jsb lcomp # call string comparison routine
11624: .long er_124 # lge first argument is not string
11625: .long er_125 # lge second argument is not string
11626: .long exfal # fail if llt
11627: .long exnul # return null if leq
11628: .long exnul # return null if lgt
11629: #page
11630: #
11631: # LGT
11632: #
11633: s$lgt: # entry point
11634: jsb lcomp # call string comparison routine
11635: .long er_126 # lgt first argument is not string
11636: .long er_127 # lgt second argument is not string
11637: .long exfal # fail if llt
11638: .long exfal # fail if leq
11639: .long exnul # return null if lgt
11640: #page
11641: #
11642: # LLE
11643: #
11644: s$lle: # entry point
11645: jsb lcomp # call string comparison routine
11646: .long er_128 # lle first argument is not string
11647: .long er_129 # lle second argument is not string
11648: .long exnul # return null if llt
11649: .long exnul # return null if leq
11650: .long exfal # fail if lgt
11651: #page
11652: #
11653: # LLT
11654: #
11655: s$llt: # entry point
11656: jsb lcomp # call string comparison routine
11657: .long er_130 # llt first argument is not string
11658: .long er_131 # llt second argument is not string
11659: .long exnul # return null if llt
11660: .long exfal # fail if leq
11661: .long exfal # fail if lgt
11662: #page
11663: #
11664: # LNE
11665: #
11666: s$lne: # entry point
11667: jsb lcomp # call string comparison routine
11668: .long er_132 # lne first argument is not string
11669: .long er_133 # lne second argument is not string
11670: .long exnul # return null if llt
11671: .long exfal # fail if leq
11672: .long exnul # return null if lgt
11673: #page
11674: #
11675: # LOCAL
11676: #
11677: s$loc: # entry point
11678: jsb gtsmi # get second argument (local number)
11679: .long er_134 # local second argument is not integer
11680: .long exfal # fail if out of range
11681: movl r9,r7 # save local number
11682: movl (sp)+,r9 # load first argument
11683: jsb gtnvr # point to vrblk
11684: .long sloc1 # jump if not variable name
11685: movl 4*vrfnc(r9),r9 # else load function pointer
11686: cmpl (r9),$b$pfc # jump if not program defined
11687: bnequ sloc1
11688: #
11689: # HERE IF WE HAVE A PROGRAM DEFINED FUNCTION NAME
11690: #
11691: tstl r7 # fail if second arg is zero
11692: bnequ 0f
11693: jmp exfal
11694: 0:
11695: cmpl r7,4*pfnlo(r9) # or too large
11696: blequ 0f
11697: jmp exfal
11698: 0:
11699: addl2 4*fargs(r9),r7 # else adjust offset to include args
11700: moval 0[r7],r7 # convert to bytes
11701: addl2 r7,r9 # point to local pointer
11702: movl 4*pfagb(r9),r9 # load vrblk pointer
11703: jmp exvnm # exit building nmblk
11704: #
11705: # HERE IF FIRST ARGUMENT IS NO GOOD
11706: #
11707: sloc1: jmp er_135 # local first arg is not a program function name
11708: #page
11709: #
11710: # LOAD
11711: #
11712: s$lod: # entry point
11713: jsb gtstg # load library name
11714: .long er_136 # load second argument is not string
11715: movl r9,r10 # save library name
11716: jsb xscni # prepare to scan first argument
11717: .long er_137 # load first argument is not string
11718: .long er_138 # load first argument is null
11719: movl r10,-(sp) # stack library name
11720: movl $ch$pp,r8 # set delimiter one = left paren
11721: movl r8,r10 # set delimiter two = left paren
11722: jsb xscan # scan function name
11723: movl r9,-(sp) # save ptr to function name
11724: tstl r6 # jump if left paren found
11725: bnequ slod1
11726: jmp er_139 # load first argument is missing a left paren
11727: #
11728: # HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME
11729: #
11730: slod1: jsb gtnvr # locate vrblk
11731: .long er_140 # load first argument has null function name
11732: movl r9,lodfn # save vrblk pointer
11733: clrl lodna # zero count of arguments
11734: #
11735: # LOOP TO SCAN ARGUMENT DATATYPE NAMES
11736: #
11737: slod2: movl $ch$rp,r8 # delimiter one is right paren
11738: movl $ch$cm,r10 # delimiter two is comma
11739: jsb xscan # scan next argument name
11740: incl lodna # bump argument count
11741: tstl r6 # jump if ok delimiter was found
11742: bnequ slod3
11743: jmp er_141 # load first argument is missing a right paren
11744: #page
11745: #
11746: # LOAD (CONTINUED)
11747: #
11748: # COME HERE TO ANALYZE THE DATATYPE POINTER IN (XR). THIS
11749: # CODE IS USED BOTH FOR ARGUMENTS (WA=1,2) AND FOR THE
11750: # RESULT DATATYPE (WITH WA SET TO ZERO).
11751: #
11752: slod3: movl r9,-(sp) # stack datatype name pointer
11753: movl $num01,r7 # set string code in case
11754: movl $scstr,r10 # point to /string/
11755: jsb ident # check for match
11756: .long slod4 # jump if match
11757: movl (sp),r9 # else reload name
11758: addl2 r7,r7 # set code for integer (2)
11759: movl $scint,r10 # point to /integer/
11760: jsb ident # check for match
11761: .long slod4 # jump if match
11762: movl (sp),r9 # else reload string pointer
11763: incl r7 # set code for real (3)
11764: movl $screa,r10 # point to /real/
11765: jsb ident # check for match
11766: .long slod4 # jump if match
11767: clrl r7 # else get code for no convert
11768: #
11769: # MERGE HERE WITH PROPER DATATYPE CODE IN WB
11770: #
11771: slod4: movl r7,(sp) # store code on stack
11772: cmpl r6,$num02 # loop back if arg stopped by comma
11773: beqlu slod2
11774: tstl r6 # jump if that was the result type
11775: beqlu slod5
11776: #
11777: # HERE WE SCAN OUT THE RESULT TYPE (ARG STOPPED BY ) )
11778: #
11779: movl mxlen,r8 # set dummy (impossible) delimiter 1
11780: movl r8,r10 # and delimiter two
11781: jsb xscan # scan result name
11782: clrl r6 # set code for processing result
11783: jmp slod3 # jump back to process result name
11784: #page
11785: #
11786: # LOAD (CONTINUED)
11787: #
11788: # HERE AFTER PROCESSING ALL ARGS AND RESULT
11789: #
11790: slod5: movl lodna,r6 # get number of arguments
11791: movl r6,r8 # copy for later
11792: moval 0[r6],r6 # convert length to bytes
11793: addl2 $4*efsi$,r6 # add space for standard fields
11794: jsb alloc # allocate efblk
11795: movl $b$efc,(r9) # set type word
11796: movl r8,4*fargs(r9) # set number of arguments
11797: clrl 4*efuse(r9) # set use count (dffnc will set to 1)
11798: clrl 4*efcod(r9) # zero code pointer for now
11799: movl (sp)+,4*efrsl(r9)# store result type code
11800: movl lodfn,4*efvar(r9)# store function vrblk pointer
11801: movl r6,4*eflen(r9) # store efblk length
11802: movl r9,r7 # save efblk pointer
11803: addl2 r6,r9 # point past end of efblk
11804: # set number of arguments for loop
11805: #
11806: # LOOP TO SET ARGUMENT TYPE CODES FROM STACK
11807: #
11808: slod6: movl (sp)+,-(r9) # store one type code from stack
11809: sobgtr r8,slod6 # loop till all stored
11810: #
11811: # NOW LOAD THE EXTERNAL FUNCTION AND PERFORM DEFINITION
11812: #
11813: movl (sp)+,r9 # load function string name
11814: movl (sp),r10 # load library name
11815: movl r7,(sp) # store efblk pointer
11816: jsb sysld # call function to load external func
11817: .long er_142 # load function does not exist
11818: .long er_143 # load function caused input error during load
11819: movl (sp)+,r10 # recall efblk pointer
11820: movl r9,4*efcod(r10) # store code pointer
11821: movl lodfn,r9 # point to vrblk for function
11822: jsb dffnc # perform function definition
11823: jmp exnul # return null result
11824: #page
11825: #
11826: # LPAD
11827: #
11828: s$lpd: # entry point
11829: jsb gtstg # get pad character
11830: .long er_144 # lpad third argument not a string
11831: movab cfp$f(r9),r9 # point to character (null is blank)
11832: movzbl (r9),r7 # load pad character
11833: jsb gtsmi # get pad length
11834: .long er_145 # lpad second argument is not integer
11835: .long slpd3 # skip if negative or large
11836: #
11837: # MERGE TO CHECK FIRST ARG
11838: #
11839: slpd1: jsb gtstg # get first argument (string to pad)
11840: .long er_146 # lpad first argument is not string
11841: cmpl r6,r8 # return 1st arg if too long to pad
11842: blssu 0f
11843: jmp exixr
11844: 0:
11845: movl r9,r10 # else move ptr to string to pad
11846: #
11847: # NOW WE ARE READY FOR THE PAD
11848: #
11849: # (XL) POINTER TO STRING TO PAD
11850: # (WB) PAD CHARACTER
11851: # (WC) LENGTH TO PAD STRING TO
11852: #
11853: movl r8,r6 # copy length
11854: jsb alocs # allocate scblk for new string
11855: movl r9,-(sp) # save as result
11856: movl 4*sclen(r10),r6 # load length of argument
11857: subl2 r6,r8 # calculate number of pad characters
11858: movab cfp$f(r9),r9 # point to chars in result string
11859: # set counter for pad loop
11860: #
11861: # LOOP TO PERFORM PAD
11862: #
11863: slpd2: movb r7,(r9)+ # store pad character, bump ptr
11864: sobgtr r8,slpd2 # loop till all pad chars stored
11865: #csc r9 # complete store characters
11866: #
11867: # NOW COPY STRING
11868: #
11869: tstl r6 # exit if null string
11870: bnequ 0f
11871: jmp exits
11872: 0:
11873: movab cfp$f(r10),r10 # else point to chars in argument
11874: jsb sbmvc # move characters to result string
11875: jmp exits # jump for next code word
11876: #
11877: # HERE IF 2ND ARG IS NEGATIVE OR LARGE
11878: #
11879: slpd3: clrl r8 # zero pad count
11880: jmp slpd1 # merge
11881: #page
11882: #
11883: # LT
11884: #
11885: s$ltf: # entry point
11886: jsb acomp # call arithmetic comparison routine
11887: .long er_147 # lt first argument is not numeric
11888: .long er_148 # lt second argument is not numeric
11889: .long exnul # return null if lt
11890: .long exfal # fail if eq
11891: .long exfal # fail if gt
11892: #page
11893: #
11894: # NE
11895: #
11896: s$nef: # entry point
11897: jsb acomp # call arithmetic comparison routine
11898: .long er_149 # ne first argument is not numeric
11899: .long er_150 # ne second argument is not numeric
11900: .long exnul # return null if lt
11901: .long exfal # fail if eq
11902: .long exnul # return null if gt
11903: #page
11904: #
11905: # NOTANY
11906: #
11907: s$nay: # entry point
11908: movl $p$nas,r7 # set pcode for single char arg
11909: movl $p$nay,r10 # pcode for multi-char arg
11910: movl $p$nad,r8 # set pcode for expr arg
11911: jsb patst # call common routine to build node
11912: .long er_151 # notany argument is not string or expression
11913: jmp exixr # jump for next code word
11914: #page
11915: #
11916: # OPSYN
11917: #
11918: s$ops: # entry point
11919: jsb gtsmi # load third argument
11920: .long er_152 # opsyn third argument is not integer
11921: .long er_153 # opsyn third argument is negative or too large
11922: movl r8,r7 # if ok, save third argumnet
11923: movl (sp)+,r9 # load second argument
11924: jsb gtnvr # locate variable block
11925: .long er_154 # opsyn second arg is not natural variable name
11926: movl 4*vrfnc(r9),r10 # if ok, load function block pointer
11927: tstl r7 # jump if operator opsyn case
11928: bnequ sops2
11929: #
11930: # HERE FOR FUNCTION OPSYN (THIRD ARG ZERO)
11931: #
11932: movl (sp)+,r9 # load first argument
11933: jsb gtnvr # get vrblk pointer
11934: .long er_155 # opsyn first arg is not natural variable name
11935: #
11936: # MERGE HERE TO PERFORM FUNCTION DEFINITION
11937: #
11938: sops1: jsb dffnc # call function definer
11939: jmp exnul # exit with null result
11940: #
11941: # HERE FOR OPERATOR OPSYN (THIRD ARG NON-ZERO)
11942: #
11943: sops2: jsb gtstg # get operator name
11944: .long sops5 # jump if not string
11945: cmpl r6,$num01 # error if not one char long
11946: bnequ sops5
11947: movab cfp$f(r9),r9 # else point to character
11948: movzbl (r9),r8 # load character name
11949: #page
11950: #
11951: # OPSYN (CONTINUED)
11952: #
11953: # NOW SET TO SEARCH FOR MATCHING UNARY OR BINARY OPERATOR
11954: # NAME AS APPROPRIATE. NOTE THAT THERE ARE =OPBUN UNDEFINED
11955: # BINARY OPERATORS AND =OPUUN UNDEFINED UNARY OPERATORS.
11956: #
11957: movl $r$uub,r6 # point to unop pointers in case
11958: movl $opnsu,r9 # point to names of unary operators
11959: addl2 $opbun,r7 # add no. of undefined binary ops
11960: cmpl r7,$opuun # jump if unop (third arg was 1)
11961: beqlu sops3
11962: movl $r$uba,r6 # else point to binary operator ptrs
11963: movl $opsnb,r9 # point to names of binary operators
11964: movl $opbun,r7 # set number of undefined binops
11965: #
11966: # MERGE HERE TO CHECK LIST (WB = NUMBER TO CHECK)
11967: #
11968: sops3: # set counter to control loop
11969: #
11970: # LOOP TO SEARCH FOR NAME MATCH
11971: #
11972: sops4: cmpl r8,(r9) # jump if names match
11973: beqlu sops6
11974: addl2 $4,r6 # else push pointer to function ptr
11975: addl2 $4,r9 # bump pointer
11976: sobgtr r7,sops4 # loop back till all checked
11977: #
11978: # HERE IF BAD OPERATOR NAME
11979: #
11980: sops5: jmp er_156 # opsyn first arg is not correct operator name
11981: #
11982: # COME HERE ON FINDING A MATCH IN THE OPERATOR NAME TABLE
11983: #
11984: sops6: movl r6,r9 # copy pointer to function block ptr
11985: subl2 $4*vrfnc,r9 # make it look like dummy vrblk
11986: jmp sops1 # merge back to define operator
11987: #page
11988: #
11989: # OUTPUT
11990: #
11991: s$oup: # entry point
11992: movl $num03,r7 # output flag
11993: jsb ioput # call input/output assoc. routine
11994: .long er_157 # output third argument is not a string
11995: .long er_158 # inappropriate second argument for output
11996: .long er_159 # inappropriate first argument for output
11997: .long er_160 # inappropriate file specification for output
11998: .long exfal # fail if file does not exist
11999: .long er_161 # output file cannot be written to
12000: jmp exnul # return null string
12001: #page
12002: #
12003: # POS
12004: #
12005: s$pos: # entry point
12006: movl $p$pos,r7 # set pcode for integer arg case
12007: movl $p$psd,r6 # set pcode for expression arg case
12008: jsb patin # call common routine to build node
12009: .long er_162 # pos argument is not integer or expression
12010: .long er_163 # pos argument is negative or too large
12011: jmp exixr # return pattern node
12012: #page
12013: #
12014: # PROTOTYPE
12015: #
12016: s$pro: # entry point
12017: movl (sp)+,r9 # load argument
12018: movl 4*tblen(r9),r7 # length if table, vector (=vclen)
12019: ashl $-2,r7,r7 # convert to words
12020: movl (r9),r6 # load type word of argument block
12021: cmpl r6,$b$art # jump if array
12022: beqlu spro4
12023: cmpl r6,$b$tbt # jump if table
12024: beqlu spro1
12025: cmpl r6,$b$vct # jump if vector
12026: beqlu spro3
12027: cmpl r6,$b$bct # jump if buffer
12028: beqlu spr05
12029: jmp er_164 # prototype argument is not valid object
12030: #
12031: # HERE FOR TABLE
12032: #
12033: spro1: subl2 $tbsi$,r7 # subtract standard fields
12034: #
12035: # MERGE FOR VECTOR
12036: #
12037: spro2: movl r7,r5 # convert to integer
12038: jmp exint # exit with integer result
12039: #
12040: # HERE FOR VECTOR
12041: #
12042: spro3: subl2 $vcsi$,r7 # subtract standard fields
12043: jmp spro2 # merge
12044: #
12045: # HERE FOR ARRAY
12046: #
12047: spro4: addl2 4*arofs(r9),r9 # point to prototype field
12048: movl (r9),r9 # load prototype
12049: jmp exixr # return prototype as result
12050: #
12051: # HERE FOR BUFFER
12052: #
12053: spr05: movl 4*bcbuf(r9),r9 # point to bfblk
12054: movl 4*bfalc(r9),r5 # load allocated length
12055: jmp exint # exit with integer allocation
12056: #page
12057: #
12058: # REMDR
12059: #
12060: s$rmd: # entry point
12061: clrl r7 # set positive flag
12062: movl (sp),r9 # load second argument
12063: jsb gtint # convert to integer
12064: .long er_165 # remdr second argument is not integer
12065: jsb arith # convert args
12066: .long srm01 # first arg not integer
12067: .long invalid$ # second arg checked above
12068: .long srm01 # first arg real
12069: movl 4*icval(r9),r5 # load left argument value
12070: ashq $-32,r4,r4 # get remainder
12071: ediv 4*icval(r10),r4,r11,r5
12072: bvs 0f
12073: jmp exint
12074: 0:
12075: jmp er_167 # remdr caused integer overflow
12076: #
12077: # FAIL FIRST ARGUMENT
12078: #
12079: srm01: jmp er_166 # remdr first argument is not integer
12080: #page
12081: #
12082: # REPLACE
12083: #
12084: # THE ACTUAL REPLACE OPERATION USES AN SCBLK WHOSE CFP$A
12085: # CHARS CONTAIN THE TRANSLATED VERSIONS OF ALL THE CHARS.
12086: # THE TABLE POINTER IS REMEMBERED FROM CALL TO CALL AND
12087: # THE TABLE IS ONLY BUILT WHEN THE ARGUMENTS CHANGE.
12088: #
12089: s$rpl: # entry point
12090: jsb gtstg # load third argument as string
12091: .long er_168 # replace third argument is not string
12092: movl r9,r10 # save third arg ptr
12093: jsb gtstg # get second argument
12094: .long er_169 # replace second argument is not string
12095: #
12096: # CHECK TO SEE IF THIS IS THE SAME TABLE AS LAST TIME
12097: #
12098: cmpl r9,r$ra2 # jump if 2nd argument different
12099: bnequ srpl1
12100: cmpl r10,r$ra3 # jump if args same as last time
12101: bnequ 0f
12102: jmp srpl4
12103: 0:
12104: #
12105: # HERE WE BUILD A NEW REPLACE TABLE (NOTE WA = 2ND ARG LEN)
12106: #
12107: srpl1: movl 4*sclen(r10),r7 # load 3rd argument length
12108: cmpl r6,r7 # jump if arguments not same length
12109: beqlu 0f
12110: jmp srpl5
12111: 0:
12112: tstl r7 # jump if null 2nd argument
12113: bnequ 0f
12114: jmp srpl5
12115: 0:
12116: movl r10,r$ra3 # save third arg for next time in
12117: movl r9,r$ra2 # save second arg for next time in
12118: movl kvalp,r10 # point to alphabet string
12119: movl 4*sclen(r10),r6 # load alphabet scblk length
12120: movl r$rpt,r9 # point to current table (if any)
12121: bnequ srpl2 # jump if we already have a table
12122: #
12123: # HERE WE ALLOCATE A NEW TABLE
12124: #
12125: jsb alocs # allocate new table
12126: movl r8,r6 # keep scblk length
12127: movl r9,r$rpt # save table pointer for next time
12128: #
12129: # MERGE HERE WITH POINTER TO NEW TABLE BLOCK IN (XR)
12130: #
12131: srpl2: movab 3+(4*scsi$)(r6),r6 # compute length of scblk
12132: bicl2 $3,r6
12133: jsb sbmvw # copy to get initial table values
12134: #page
12135: #
12136: # REPLACE (CONTINUED)
12137: #
12138: # NOW WE MUST PLUG SELECTED ENTRIES AS REQUIRED. NOTE THAT
12139: # WE ARE SHORT OF INDEX REGISTERS FOR THE FOLLOWING LOOP.
12140: # HENCE THE NEED TO REPEATEDLY RE-INITIALISE CHAR PTR XL
12141: #
12142: movl r$ra2,r10 # point to second argument
12143: # number of chars to plug
12144: clrl r8 # zero char offset
12145: movl r$ra3,r9 # point to 3rd arg
12146: movab cfp$f(r9),r9 # get char ptr for 3rd arg
12147: #
12148: # LOOP TO PLUG CHARS
12149: #
12150: srpl3: movl r$ra2,r10 # point to 2nd arg
12151: movab cfp$f(r10)[r8],r10 # point to next char
12152: incl r8 # increment offset
12153: movzbl (r10),r6 # get next char
12154: movl r$rpt,r10 # point to translate table
12155: movab cfp$f(r10)[r6],r10 # convert char to offset into table
12156: movzbl (r9)+,r6 # get translated char
12157: movb r6,(r10) # store in table
12158: #csc r10 # complete store characters
12159: sobgtr r7,srpl3 # loop till done
12160: #page
12161: #
12162: # REPLACE (CONTINUED)
12163: #
12164: # HERE TO PERFORM TRANSLATE
12165: #
12166: srpl4: jsb gtstg # get first argument
12167: .long er_170 # replace first argument is not string
12168: tstl r6 # return null if null argument
12169: bnequ 0f
12170: jmp exnul
12171: 0:
12172: movl r9,r10 # copy pointer
12173: movl r6,r8 # save length
12174: movab 3+(4*schar)(r6),r6 # get scblk length
12175: bicl2 $3,r6
12176: jsb alloc # allocate space for copy
12177: movl r9,r7 # save address of copy
12178: jsb sbmvw # move scblk contents to copy
12179: movl r$rpt,r9 # point to replace table
12180: movab cfp$f(r9),r9 # point to chars of table
12181: movl r7,r10 # point to string to translate
12182: movab cfp$f(r10),r10 # point to chars of string
12183: movl r8,r6 # set number of chars to translate
12184: jsb sbtrc # perform translation
12185: movl r7,-(sp) # stack new string as result
12186: jmp exits # return with result on stack
12187: #
12188: # ERROR POINT
12189: #
12190: srpl5: jmp er_171 # null or unequally long 2nd, 3rd args to replace
12191: #page
12192: #
12193: # REWIND
12194: #
12195: s$rew: # entry point
12196: jsb iofcb # call fcblk routine
12197: .long er_172 # rewind argument is not a suitable name
12198: .long er_173 # rewind argument is null
12199: jsb sysrw # call system rewind function
12200: .long er_174 # rewind file does not exist
12201: .long er_175 # rewind file does not permit rewind
12202: .long er_176 # rewind caused non-recoverable error
12203: jmp exnul # exit with null result if no error
12204: #page
12205: #
12206: # REVERSE
12207: #
12208: s$rvs: # entry point
12209: jsb gtstg # load string argument
12210: .long er_177 # reverse argument is not string
12211: tstl r6 # return argument if null
12212: bnequ 0f
12213: jmp exixr
12214: 0:
12215: movl r9,r10 # else save pointer to string arg
12216: jsb alocs # allocate space for new scblk
12217: movl r9,-(sp) # store scblk ptr on stack as result
12218: movab cfp$f(r9),r9 # prepare to store in new scblk
12219: movab cfp$f(r10)[r8],r10 # point past last char in argument
12220: # set loop counter
12221: #
12222: # LOOP TO MOVE CHARS IN REVERSE ORDER
12223: #
12224: srvs1: movzbl -(r10),r7 # load next char from argument
12225: movb r7,(r9)+ # store in result
12226: sobgtr r8,srvs1 # loop till all moved
12227: #csc r9 # complete store characters
12228: jmp exits # and then jump for next code word
12229: #page
12230: #
12231: # RPAD
12232: #
12233: s$rpd: # entry point
12234: jsb gtstg # get pad character
12235: .long er_178 # rpad third argument is not string
12236: movab cfp$f(r9),r9 # point to character (null is blank)
12237: movzbl (r9),r7 # load pad character
12238: jsb gtsmi # get pad length
12239: .long er_179 # rpad second argument is not integer
12240: .long srpd3 # skip if negative or large
12241: #
12242: # MERGE TO CHECK FIRST ARG.
12243: #
12244: srpd1: jsb gtstg # get first argument (string to pad)
12245: .long er_180 # rpad first argument is not string
12246: cmpl r6,r8 # return 1st arg if too long to pad
12247: blssu 0f
12248: jmp exixr
12249: 0:
12250: movl r9,r10 # else move ptr to string to pad
12251: #
12252: # NOW WE ARE READY FOR THE PAD
12253: #
12254: # (XL) POINTER TO STRING TO PAD
12255: # (WB) PAD CHARACTER
12256: # (WC) LENGTH TO PAD STRING TO
12257: #
12258: movl r8,r6 # copy length
12259: jsb alocs # allocate scblk for new string
12260: movl r9,-(sp) # save as result
12261: movl 4*sclen(r10),r6 # load length of argument
12262: subl2 r6,r8 # calculate number of pad characters
12263: movab cfp$f(r9),r9 # point to chars in result string
12264: # set counter for pad loop
12265: #
12266: # COPY ARGUMENT STRING
12267: #
12268: tstl r6 # jump if argument is null
12269: beqlu srpd2
12270: movab cfp$f(r10),r10 # else point to argument chars
12271: jsb sbmvc # move characters to result string
12272: #
12273: # LOOP TO SUPPLY PAD CHARACTERS
12274: #
12275: srpd2: movb r7,(r9)+ # store pad character, bump ptr
12276: sobgtr r8,srpd2 # loop till all pad chars stored
12277: #csc r9 # complete character storing
12278: jmp exits # and exit for next word
12279: #
12280: # HERE IF 2ND ARG IS NEGATIVE OR LARGE
12281: #
12282: srpd3: clrl r8 # zero pad count
12283: jmp srpd1 # merge
12284: #page
12285: #
12286: # RTAB
12287: #
12288: s$rtb: # entry point
12289: movl $p$rtb,r7 # set pcode for integer arg case
12290: movl $p$rtd,r6 # set pcode for expression arg case
12291: jsb patin # call common routine to build node
12292: .long er_181 # rtab argument is not integer or expression
12293: .long er_182 # rtab argument is negative or too large
12294: jmp exixr # return pattern node
12295: #page
12296: #
12297: # SET
12298: #
12299: s$set: # entry point
12300: movl (sp)+,r$io2 # save third arg
12301: movl (sp)+,r$io1 # save second arg
12302: jsb iofcb # call fcblk routine
12303: .long er_291 # set first argument is not a suitable name
12304: .long er_292 # set first argument is null
12305: movl r$io1,r7 # load second arg
12306: movl r$io2,r8 # load third arg
12307: jsb sysst # call system set routine
12308: .long er_293 # inappropriate second argument to set
12309: .long er_294 # inappropriate third argument to set
12310: .long er_295 # set file does not exist
12311: .long er_296 # set file does not permit setting file pointer
12312: .long er_297 # set caused non-recoverable i/o error
12313: jmp exnul # otherwisew return null
12314: #page
12315: #
12316: # TAB
12317: #
12318: s$tab: # entry point
12319: movl $p$tab,r7 # set pcode for integer arg case
12320: movl $p$tbd,r6 # set pcode for expression arg case
12321: jsb patin # call common routine to build node
12322: .long er_183 # tab argument is not integer or expression
12323: .long er_184 # tab argument is negative or too large
12324: jmp exixr # return pattern node
12325: #page
12326: #
12327: # RPOS
12328: #
12329: s$rps: # entry point
12330: movl $p$rps,r7 # set pcode for integer arg case
12331: movl $p$rpd,r6 # set pcode for expression arg case
12332: jsb patin # call common routine to build node
12333: .long er_185 # rpos argument is not integer or expression
12334: .long er_186 # rpos argument is negative or too large
12335: jmp exixr # return pattern node
12336: #page
12337: #
12338: # RSORT
12339: #
12340: s$rsr: # entry point
12341: movl sp,r6 # mark as rsort
12342: jsb sorta # call sort routine
12343: jmp exsid # return, setting idval
12344: #page
12345: #
12346: # SETEXIT
12347: #
12348: s$stx: # entry point
12349: movl (sp)+,r9 # load argument
12350: movl stxvr,r6 # load old vrblk pointer
12351: clrl r10 # load zero in case null arg
12352: cmpl r9,$nulls # jump if null argument (reset call)
12353: beqlu sstx1
12354: jsb gtnvr # else get specified vrblk
12355: .long sstx2 # jump if not natural variable
12356: movl 4*vrlbl(r9),r10 # else load label
12357: cmpl r10,$stndl # jump if label is not defined
12358: beqlu sstx2
12359: cmpl (r10),$b$trt # jump if not trapped
12360: bnequ sstx1
12361: movl 4*trlbl(r10),r10# else load ptr to real label code
12362: #
12363: # HERE TO SET/RESET SETEXIT TRAP
12364: #
12365: sstx1: movl r9,stxvr # store new vrblk pointer (or null)
12366: movl r10,r$sxc # store new code ptr (or zero)
12367: cmpl r6,$nulls # return null if null result
12368: bnequ 0f
12369: jmp exnul
12370: 0:
12371: movl r6,r9 # else copy vrblk pointer
12372: jmp exvnm # and return building nmblk
12373: #
12374: # HERE IF BAD ARGUMENT
12375: #
12376: sstx2: jmp er_187 # setexit argument is not label name or null
12377: #page
12378: #
12379: # SORT
12380: #
12381: s$srt: # entry point
12382: clrl r6 # mark as sort
12383: jsb sorta # call sort routine
12384: jmp exsid # return, setting idval
12385: #page
12386: #
12387: # SPAN
12388: #
12389: s$spn: # entry point
12390: movl $p$sps,r7 # set pcode for single char arg
12391: movl $p$spn,r10 # set pcode for multi-char arg
12392: movl $p$spd,r8 # set pcode for expression arg
12393: jsb patst # call common routine to build node
12394: .long er_188 # span argument is not string or expression
12395: jmp exixr # jump for next code word
12396: #page
12397: #
12398: # SIZE
12399: #
12400: s$si$: # entry point
12401: movl (sp),r9 # load argument
12402: cmpl (r9),$b$bct # branch if not buffer
12403: bnequ ssi$1
12404: addl2 $4,sp # else pop argument
12405: movl 4*bclen(r9),r5 # load defined length
12406: jmp exint # exit with integer
12407: #
12408: # HERE IF NOT BUFFER
12409: #
12410: ssi$1: jsb gtstg # load string argument
12411: .long er_189 # size argument is not string
12412: movl r6,r5 # load length as integer
12413: jmp exint # exit with integer result
12414: #page
12415: #
12416: # STOPTR
12417: #
12418: s$stt: # entry point
12419: clrl r10 # indicate stoptr case
12420: jsb trace # call trace procedure
12421: .long er_190 # stoptr first argument is not appropriate name
12422: .long er_191 # stoptr second argument is not trace type
12423: jmp exnul # return null
12424: #page
12425: #
12426: # SUBSTR
12427: #
12428: s$sub: # entry point
12429: jsb gtsmi # load third argument
12430: .long er_192 # substr third argument is not integer
12431: .long exfal # jump if negative or too large
12432: movl r9,sbssv # save third argument
12433: jsb gtsmi # load second argument
12434: .long er_193 # substr second argument is not integer
12435: .long exfal # jump if out of range
12436: movl r9,r7 # save second argument
12437: bnequ 0f # jump if second argument zero
12438: jmp exfal
12439: 0:
12440: decl r7 # else decrement for ones origin
12441: movl (sp),r10 # get first arg ptr
12442: cmpl (r10),$b$bct # branch if not buffer
12443: bnequ ssuba
12444: movl 4*bcbuf(r10),r9 # get bfblk ptr
12445: movl 4*bclen(r10),r6 # get length
12446: jmp ssubb # merge
12447: #
12448: # HERE IF NOT BUFFER TO GET STRING
12449: #
12450: ssuba: jsb gtstg # load first argument
12451: .long er_194 # substr first argument is not string
12452: #
12453: # MERGE WITH BFBLK OR SCBLK PTR IN XR. WA HAS LENGTH
12454: #
12455: ssubb: movl sbssv,r8 # reload third argument
12456: bnequ ssub1 # skip if third arg given
12457: movl r6,r8 # else get string length
12458: cmpl r7,r8 # fail if improper
12459: blequ 0f
12460: jmp exfal
12461: 0:
12462: subl2 r7,r8 # reduce by offset to start
12463: #
12464: # MERGE
12465: #
12466: ssub1: movl r6,r10 # save string length
12467: movl r8,r6 # set length of substring
12468: addl2 r7,r8 # add 2nd arg to 3rd arg
12469: cmpl r8,r10 # jump if improper substring
12470: blequ 0f
12471: jmp exfal
12472: 0:
12473: movl r9,r10 # copy pointer to first arg
12474: jsb sbstr # build substring
12475: jmp exixr # and jump for next code word
12476: #page
12477: #
12478: # TABLE
12479: #
12480: s$tbl: # entry point
12481: movl (sp)+,r10 # get initial lookup value
12482: addl2 $4,sp # pop second argument
12483: jsb gtsmi # load argument
12484: .long er_195 # table argument is not integer
12485: .long er_196 # table argument is out of range
12486: tstl r8 # jump if non-zero
12487: bnequ stbl1
12488: movl $tbnbk,r8 # else supply default value
12489: #
12490: # MERGE HERE WITH NUMBER OF HEADERS IN WA
12491: #
12492: stbl1: movl r8,r6 # copy number of headers
12493: addl2 $tbsi$,r6 # adjust for standard fields
12494: moval 0[r6],r6 # convert length to bytes
12495: jsb alloc # allocate space for tbblk
12496: movl r9,r7 # copy pointer to tbblk
12497: movl $b$tbt,(r9)+ # store type word
12498: clrl (r9)+ # zero id for the moment
12499: movl r6,(r9)+ # store length (tblen)
12500: movl r10,(r9)+ # store initial lookup value
12501: # set loop counter (num headers)
12502: #
12503: # LOOP TO INITIALIZE ALL BUCKET POINTERS
12504: #
12505: stbl2: movl r7,(r9)+ # store tbblk ptr in bucket header
12506: sobgtr r8,stbl2 # loop till all stored
12507: movl r7,r9 # recall pointer to tbblk
12508: jmp exsid # exit setting idval
12509: #page
12510: #
12511: # TIME
12512: #
12513: s$tim: # entry point
12514: jsb systm # get timer value
12515: subl2 timsx,r5 # subtract starting time
12516: jmp exint # exit with integer value
12517: #page
12518: #
12519: # TRACE
12520: #
12521: s$tra: # entry point
12522: cmpl 4*3(sp),$nulls # jump if first argument is null
12523: beqlu str03
12524: movl (sp)+,r9 # load fourth argument
12525: clrl r10 # tentatively set zero pointer
12526: cmpl r9,$nulls # jump if 4th argument is null
12527: beqlu str02
12528: jsb gtnvr # else point to vrblk
12529: .long str01 # jump if not variable name
12530: movl 4*vrfnc(r9),r10 # else load function pointer
12531: cmpl r10,$stndf # jump if function is defined
12532: bnequ str02
12533: #
12534: # HERE FOR BAD FOURTH ARGUMENT
12535: #
12536: str01: jmp er_197 # trace fourth arg is not function name or null
12537: #
12538: # HERE WITH FUNCTION POINTER IN XL
12539: #
12540: str02: movl (sp)+,r9 # load third argument (tag)
12541: clrl r7 # set zero as trtyp value for now
12542: jsb trbld # build trblk for trace call
12543: movl r9,r10 # move trblk pointer for trace
12544: jsb trace # call trace procedure
12545: .long er_198 # trace first argument is not appropriate name
12546: .long er_199 # trace second argument is not trace type
12547: jmp exnul # return null
12548: #
12549: # HERE TO CALL SYSTEM TRACE TOGGLE ROUTINE
12550: #
12551: str03: jsb systt # call it
12552: addl2 $4*num04,sp # pop trace arguments
12553: jmp exnul # return
12554: #page
12555: #
12556: # TRIM
12557: #
12558: s$trm: # entry point
12559: jsb gtstg # load argument as string
12560: .long er_200 # trim argument is not string
12561: tstl r6 # return null if argument is null
12562: bnequ 0f
12563: jmp exnul
12564: 0:
12565: movl r9,r10 # copy string pointer
12566: movab 3+(4*schar)(r6),r6 # get block length
12567: bicl2 $3,r6
12568: jsb alloc # allocate copy same size
12569: movl r9,r7 # save pointer to copy
12570: jsb sbmvw # copy old string block to new
12571: movl r7,r9 # restore ptr to new block
12572: jsb trimr # trim blanks (wb is non-zero)
12573: jmp exixr # exit with result in xr
12574: #page
12575: #
12576: # UNLOAD
12577: #
12578: s$unl: # entry point
12579: movl (sp)+,r9 # load argument
12580: jsb gtnvr # point to vrblk
12581: .long er_201 # unload argument is not natural variable name
12582: movl $stndf,r10 # get ptr to undefined function
12583: jsb dffnc # undefine named function
12584: jmp exnul # return null as result
12585: #title s p i t b o l -- utility procedures
12586: #
12587: # THE FOLLOWING SECTION CONTAINS PROCEDURES WHICH ARE
12588: # USED FOR VARIOUS PURPOSES THROUGHOUT THE SYSTEM.
12589: #
12590: # EACH PROCEDURE IS PRECEDED BY A DESCRIPTION OF THE
12591: # CALLING SEQUENCE. USUALLY THE ARGUMENTS ARE IN REGISTERS
12592: # BUT ARGUMENTS CAN ALSO OCCUR ON THE STACK AND AS
12593: # PARAMETERS ASSEMBLED AFTER THE JSR INSTRUCTION.
12594: #
12595: # THE FOLLOWING CONSIDERATIONS APPLY TO THESE DESCRIPTIONS.
12596: #
12597: # 1) THE STACK POINTER (XS) IS NOT CHANGED UNLESS THE
12598: # CHANGE IS EXPLICITLY DOCUMENTED IN THE CALL.
12599: #
12600: # 2) REGISTERS WHOSE ENTRY VALUES ARE NOT MENTIONED
12601: # MAY CONTAIN ANY VALUE EXCEPT THAT XL,XR MAY ONLY
12602: # CONTAIN PROPER (COLLECTABLE) POINTER VALUES.
12603: # THIS CONDITION ON XR MEANS THAT THE CALLED ROUTINE
12604: # MAY IF IT CHOOSES PRESERVE XR BY STACKING.
12605: #
12606: # 3) REGISTERS NOT MENTIONED ON EXIT CONTAIN THE SAME
12607: # VALUES AS THEY DID ON ENTRY EXCEPT THAT VALUES IN
12608: # XR,XL MAY HAVE BEEN RELOCATED BY THE COLLECTOR.
12609: #
12610: # 4) REGISTERS WHICH ARE DESTROYED ON EXIT MAY CONTAIN
12611: # ANY VALUE EXCEPT THAT VALUES IN XL,XR ARE PROPER
12612: # (COLLECTABLE) POINTERS.
12613: #
12614: # 5) THE CODE POINTER REGISTER POINTS TO THE CURRENT
12615: # CODE LOCATION ON ENTRY AND IS UNCHANGED ON EXIT.
12616: #
12617: # IN THE ABOVE DESCRIPTION, A COLLECTABLE POINTER IS ONE
12618: # WHICH EITHER POINTS OUTSIDE THE DYNAMIC REGION OR
12619: # POINTS TO THE START OF A BLOCK IN THE DYNAMIC REGION.
12620: #
12621: # IN THOSE CASES WHERE THE CALLING SEQUENCE CONTAINS
12622: # PARAMETERS WHICH ARE USED AS ALTERNATE RETURN POINTS,
12623: # THESE PARAMETERS MAY BE REPLACED BY ERROR CODES
12624: # ASSEMBLED WITH THE ERR INSTRUCTION. THIS WILL RESULT
12625: # IN THE POSTING OF THE ERROR IF THE RETURN IS TAKEN.
12626: #
12627: # THE PROCEDURES ALL HAVE NAMES CONSISTING OF FIVE LETTERS
12628: # AND ARE IN ALPHABETICAL ORDER BY THEIR NAMES.
12629: #page
12630: #
12631: # ACESS - ACCESS VARIABLE VALUE WITH TRACE/INPUT CHECKS
12632: #
12633: # ACESS LOADS THE VALUE OF A VARIABLE. TRACE AND INPUT
12634: # ASSOCIATIONS ARE TESTED FOR AND EXECUTED AS REQUIRED.
12635: # ACESS ALSO HANDLES THE SPECIAL CASES OF PSEUDO-VARIABLES.
12636: #
12637: # (XL) VARIABLE NAME BASE
12638: # (WA) VARIABLE NAME OFFSET
12639: # JSR ACESS CALL TO ACCESS VALUE
12640: # PPM LOC TRANSFER LOC IF ACCESS FAILURE
12641: # (XR) VARIABLE VALUE
12642: # (WA,WB,WC) DESTROYED
12643: # (XL,RA) DESTROYED
12644: #
12645: # FAILURE CAN OCCUR IF AN INPUT ASSOCIATION CAUSES AN END
12646: # OF FILE CONDITION OR IF THE EVALUATION OF AN EXPRESSION
12647: # ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS.
12648: #
12649: acess: #prc # entry point (recursive)
12650: movl r10,r9 # copy name base
12651: addl2 r6,r9 # point to variable location
12652: movl (r9),r9 # load variable value
12653: #
12654: # LOOP HERE TO CHECK FOR SUCCESSIVE TRBLKS
12655: #
12656: acs02: cmpl (r9),$b$trt # jump if not trapped
12657: beqlu 0f
12658: jmp acs18
12659: 0:
12660: #
12661: # HERE IF TRAPPED
12662: #
12663: cmpl r9,$trbkv # jump if keyword variable
12664: bnequ 0f
12665: jmp acs12
12666: 0:
12667: cmpl r9,$trbev # jump if not expression variable
12668: bnequ acs05
12669: #
12670: # HERE FOR EXPRESSION VARIABLE, EVALUATE VARIABLE
12671: #
12672: movl 4*evexp(r10),r9 # load expression pointer
12673: clrl r7 # evaluate by value
12674: jsb evalx # evaluate expression
12675: .long acs04 # jump if evaluation failure
12676: jmp acs02 # check value for more trblks
12677: #page
12678: #
12679: # ACESS (CONTINUED)
12680: #
12681: # HERE ON READING END OF FILE
12682: #
12683: acs03: addl2 $4*num03,sp # pop trblk ptr, name base and offset
12684: movl r9,dnamp # pop unused scblk
12685: #
12686: # MERGE HERE WHEN EVALUATION OF EXPRESSION FAILS
12687: #
12688: acs04: movl (sp)+,r11 # take alternate (failure) return
12689: jmp *(r11)+
12690: #
12691: # HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
12692: #
12693: acs05: movl 4*trtyp(r9),r7 # load trap type code
12694: beqlu 0f # jump if not input association
12695: jmp acs10
12696: 0:
12697: tstl kvinp # ignore input assoc if input is off
12698: bnequ 0f
12699: jmp acs09
12700: 0:
12701: #
12702: # HERE FOR INPUT ASSOCIATION
12703: #
12704: movl r10,-(sp) # stack name base
12705: movl r6,-(sp) # stack name offset
12706: movl r9,-(sp) # stack trblk pointer
12707: movl 4*trfpt(r9),r10 # get file ctrl blk ptr or zero
12708: bnequ acs06 # jump if not standard input file
12709: cmpl 4*trter(r9),$v$ter # jump if terminal
12710: bnequ 0f
12711: jmp acs21
12712: 0:
12713: #
12714: # HERE TO READ FROM STANDARD INPUT FILE
12715: #
12716: movl cswin,r6 # length for read buffer
12717: jsb alocs # build string of appropriate length
12718: jsb sysrd # read next standard input image
12719: .long acs03 # jump to fail exit if end of file
12720: jmp acs07 # else merge with other file case
12721: #
12722: # HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE
12723: #
12724: acs06: movl r10,r6 # fcblk ptr
12725: jsb sysil # get input record max length (to wa)
12726: jsb alocs # allocate string of correct size
12727: movl r10,r6 # fcblk ptr
12728: jsb sysin # call system input routine
12729: .long acs03 # jump to fail exit if end of file
12730: .long acs22 # error
12731: .long acs23 # error
12732: #page
12733: #
12734: # ACESS (CONTINUED)
12735: #
12736: # MERGE HERE AFTER OBTAINING INPUT RECORD
12737: #
12738: acs07: movl kvtrm,r7 # load trim indicator
12739: jsb trimr # trim record as required
12740: movl r9,r7 # copy result pointer
12741: movl (sp),r9 # reload pointer to trblk
12742: #
12743: # LOOP TO CHASE TO END OF TRBLK CHAIN AND STORE VALUE
12744: #
12745: acs08: movl r9,r10 # save pointer to this trblk
12746: movl 4*trnxt(r9),r9 # load forward pointer
12747: cmpl (r9),$b$trt # loop if this is another trblk
12748: beqlu acs08
12749: movl r7,4*trnxt(r10) # else store result at end of chain
12750: movl (sp)+,r9 # restore initial trblk pointer
12751: movl (sp)+,r6 # restore name offset
12752: movl (sp)+,r10 # restore name base pointer
12753: #
12754: # COME HERE TO MOVE TO NEXT TRBLK
12755: #
12756: acs09: movl 4*trnxt(r9),r9 # load forward ptr to next value
12757: jmp acs02 # back to check if trapped
12758: #
12759: # HERE TO CHECK FOR ACCESS TRACE TRBLK
12760: #
12761: acs10: cmpl r7,$trtac # loop back if not access trace
12762: beqlu 0f
12763: jmp acs09
12764: 0:
12765: tstl kvtra # ignore access trace if trace off
12766: bnequ 0f
12767: jmp acs09
12768: 0:
12769: decl kvtra # else decrement trace count
12770: tstl 4*trfnc(r9) # jump if print trace
12771: beqlu acs11
12772: #page
12773: #
12774: # ACESS (CONTINUED)
12775: #
12776: # HERE FOR FULL FUNCTION TRACE
12777: #
12778: jsb trxeq # call routine to execute trace
12779: jmp acs09 # jump for next trblk
12780: #
12781: # HERE FOR CASE OF PRINT TRACE
12782: #
12783: acs11: jsb prtsn # print statement number
12784: jsb prtnv # print name = value
12785: jmp acs09 # jump back for next trblk
12786: #
12787: # HERE FOR KEYWORD VARIABLE
12788: #
12789: acs12: movl 4*kvnum(r10),r9 # load keyword number
12790: cmpl r9,$k$v$$ # jump if not one word value
12791: bgequ acs14
12792: movl l^kvabe(r9),r5 # else load value as integer
12793: #
12794: # COMMON EXIT WITH KEYWORD VALUE AS INTEGER IN (IA)
12795: #
12796: acs13: jsb icbld # build icblk
12797: jmp acs18 # jump to exit
12798: #
12799: # HERE IF NOT ONE WORD KEYWORD VALUE
12800: #
12801: acs14: cmpl r9,$k$s$$ # jump if special case
12802: bgequ acs15
12803: subl2 $k$v$$,r9 # else get offset
12804: addl2 $ndabo,r9 # point to pattern value
12805: jmp acs18 # jump to exit
12806: #
12807: # HERE IF SPECIAL KEYWORD CASE
12808: #
12809: acs15: movl kvrtn,r10 # load rtntype in case
12810: movl kvstl,r5 # load stlimit in case
12811: subl2 $k$s$$,r9 # get case number
12812: casel r9,$0,$5 # switch on keyword number
12813: 5:
12814: .word acs16-5b # jump if alphabet
12815: .word acs17-5b # rtntype
12816: .word acs19-5b # stcount
12817: .word acs20-5b # errtext
12818: .word acs13-5b # stlimit
12819: #esw # end switch on keyword number
12820: #page
12821: #
12822: # ACESS (CONTINUED)
12823: #
12824: # ALPHABET
12825: #
12826: acs16: movl kvalp,r10 # load pointer to alphabet string
12827: #
12828: # RTNTYPE MERGES HERE
12829: #
12830: acs17: movl r10,r9 # copy string ptr to proper reg
12831: #
12832: # COMMON RETURN POINT
12833: #
12834: acs18: addl2 $4*1,(sp) # return to acess caller
12835: rsb
12836: #
12837: # HERE FOR STCOUNT (IA HAS STLIMIT)
12838: #
12839: acs19: subl2 kvstc,r5 # stcount = limit - left
12840: jmp acs13 # merge back with integer result
12841: #
12842: # ERRTEXT
12843: #
12844: acs20: movl r$etx,r9 # get errtext string
12845: jmp acs18 # merge with result
12846: #
12847: # HERE TO READ A RECORD FROM TERMINAL
12848: #
12849: acs21: movl $rilen,r6 # buffer length
12850: jsb alocs # allocate buffer
12851: jsb sysri # read record
12852: .long acs03 # endfile
12853: jmp acs07 # merge with record read
12854: #
12855: # ERROR RETURNS
12856: #
12857: acs22: movl r9,dnamp # pop unused scblk
12858: jmp er_202 # input from file caused non-recoverable error
12859: #
12860: acs23: movl r9,dnamp # pop unused scblk
12861: jmp er_203 # input file record has incorrect format
12862: #enp # end procedure acess
12863: #page
12864: #
12865: # ACOMP -- COMPARE TWO ARITHMETIC VALUES
12866: #
12867: # 1(XS) FIRST ARGUMENT
12868: # 0(XS) SECOND ARGUMENT
12869: # JSR ACOMP CALL TO COMPARE VALUES
12870: # PPM LOC TRANSFER LOC IF ARG1 IS NON-NUMERIC
12871: # PPM LOC TRANSFER LOC IF ARG2 IS NON-NUMERIC
12872: # PPM LOC TRANSFER LOC FOR ARG1 LT ARG2
12873: # PPM LOC TRANSFER LOC FOR ARG1 EQ ARG2
12874: # PPM LOC TRANSFER LOC FOR ARG1 GT ARG2
12875: # (NORMAL RETURN IS NEVER GIVEN)
12876: # (WA,WB,WC,IA,RA) DESTROYED
12877: # (XL,XR) DESTROYED
12878: #
12879: .data 1
12880: acomp_s: .long 0
12881: .text 0
12882: acomp: movl (sp)+,acomp_s # entry point
12883: jsb arith # load arithmetic operands
12884: .long acmp7 # jump if first arg non-numeric
12885: .long acmp8 # jump if second arg non-numeric
12886: .long acmp4 # jump if real arguments
12887: #
12888: # HERE FOR INTEGER ARGUMENTS
12889: #
12890: subl2 4*icval(r10),r5 # subtract to compare
12891: bvs acmp3
12892: tstl r5 # else jump if arg1 lt arg2
12893: blss acmp5
12894: tstl r5 # jump if arg1 eq arg2
12895: beql acmp2
12896: #
12897: # HERE IF ARG1 GT ARG2
12898: #
12899: acmp1: addl3 $4*4,acomp_s,r11 # take gt exit
12900: jmp *(r11)+
12901: #
12902: # HERE IF ARG1 EQ ARG2
12903: #
12904: acmp2: addl3 $4*3,acomp_s,r11 # take eq exit
12905: jmp *(r11)+
12906: #page
12907: #
12908: # ACOMP (CONTINUED)
12909: #
12910: # HERE FOR INTEGER OVERFLOW ON SUBTRACT
12911: #
12912: acmp3: movl 4*icval(r10),r5 # load second argument
12913: blss acmp1 # gt if negative
12914: jmp acmp5 # else lt
12915: #
12916: # HERE FOR REAL OPERANDS
12917: #
12918: acmp4: subf2 4*rcval(r10),r2 # subtract to compare
12919: bvs acmp6
12920: tstf r2 # else jump if arg1 gt
12921: bgtr acmp1
12922: tstf r2 # jump if arg1 eq arg2
12923: beql acmp2
12924: #
12925: # HERE IF ARG1 LT ARG2
12926: #
12927: acmp5: addl3 $4*2,acomp_s,r11 # take lt exit
12928: jmp *(r11)+
12929: #
12930: # HERE IF OVERFLOW ON REAL SUBTRACTION
12931: #
12932: acmp6: movf 4*rcval(r10),r2 # reload arg2
12933: tstf r2 # gt if negative
12934: blss acmp1
12935: jmp acmp5 # else lt
12936: #
12937: # HERE IF ARG1 NON-NUMERIC
12938: #
12939: acmp7: movl acomp_s,r11 # take error exit
12940: jmp *(r11)+
12941: #
12942: # HERE IF ARG2 NON-NUMERIC
12943: #
12944: acmp8: addl3 $4*1,acomp_s,r11 # take error exit
12945: jmp *(r11)+
12946: #enp # end procedure acomp
12947: #page
12948: #
12949: # ALLOC ALLOCATE BLOCK OF DYNAMIC STORAGE
12950: #
12951: # (WA) LENGTH REQUIRED IN BYTES
12952: # JSR ALLOC CALL TO ALLOCATE BLOCK
12953: # (XR) POINTER TO ALLOCATED BLOCK
12954: #
12955: # A POSSIBLE ALTERNATIVE TO AOV .. AND FOLLOWING STMT IS -
12956: # MOV DNAME,XR . SUB WA,XR . BLO XR,DNAMP,ALOC2 .
12957: # MOV DNAMP,XR . ADD WA,XR
12958: #
12959: alloc: #prc # entry point
12960: #
12961: # COMMON EXIT POINT
12962: #
12963: aloc1: movl dnamp,r9 # point to next available loc
12964: addl2 r6,r9 # point past allocated block
12965: bvc 0f
12966: jmp aloc2
12967: 0:
12968: cmpl r9,dname # jump if not enough room
12969: bgtru aloc2
12970: movl r9,dnamp # store new pointer
12971: subl2 r6,r9 # point back to start of allocated bk
12972: rsb # return to caller
12973: #
12974: # HERE IF INSUFFICIENT ROOM, TRY A GARBAGE COLLECTION
12975: #
12976: aloc2: movl r7,allsv # save wb
12977: clrl r7 # set no upward move for gbcol
12978: jsb gbcol # garbage collect
12979: #
12980: # SEE IF ROOM AFTER GBCOL OR SYSMM CALL
12981: #
12982: aloc3: movl dnamp,r9 # point to first available loc
12983: addl2 r6,r9 # point past new block
12984: bvc 0f
12985: jmp alc3a
12986: 0:
12987: cmpl r9,dname # jump if there is room now
12988: blequ aloc4
12989: #
12990: # FAILED AGAIN, SEE IF WE CAN GET MORE CORE
12991: #
12992: alc3a: jsb sysmm # try to get more memory
12993: moval 0[r9],r9 # convert to baus (sgd05)
12994: addl2 r9,dname # bump ptr by amount obtained
12995: tstl r9 # jump if got more core
12996: bnequ aloc3
12997: addl2 rsmem,dname # get the reserve memory
12998: clrl rsmem # only permissible once
12999: incl errft # fatal error
13000: jmp er_204 # memory overflow
13001: #page
13002: #
13003: # HERE AFTER SUCCESSFUL GARBAGE COLLECTION
13004: #
13005: aloc4: movl r5,allia # save ia
13006: movl dname,r7 # get dynamic end adrs
13007: subl2 dnamp,r7 # compute free store
13008: ashl $-2,r7,r7 # convert bytes to words
13009: movl r7,r5 # put free store in ia
13010: mull2 alfsf,r5 # multiply by free store factor
13011: bvs aloc5
13012: movl dname,r7 # dynamic end adrs
13013: subl2 dnamb,r7 # compute total amount of dynamic
13014: ashl $-2,r7,r7 # convert to words
13015: movl r7,aldyn # store it
13016: subl2 aldyn,r5 # subtract from scaled up free store
13017: bgtr aloc5 # jump if sufficient free store
13018: jsb sysmm # try to get more store
13019: moval 0[r9],r9 # convert to baus (sgd05)
13020: addl2 r9,dname # adjust dynamic end adrs
13021: #
13022: # MERGE TO RESTORE IA AND WB
13023: #
13024: aloc5: movl allia,r5 # recover ia
13025: movl allsv,r7 # restore wb
13026: jmp aloc1 # jump back to exit
13027: #enp # end procedure alloc
13028: #page
13029: #
13030: # ALOBF -- ALLOCATE BUFFER
13031: #
13032: # THIS ROUTINES ALLOCATES A NEW BUFFER. AS THE BFBLK
13033: # AND BCBLK COME IN PAIRS, BOTH ARE ALLOCATED HERE,
13034: # AND XR POINTS TO THE BCBLK ON RETURN. THE BFBLK
13035: # AND BCBLK ARE SET TO THE NULL BUFFER, AND THE IDVAL
13036: # IS ZERO ON RETURN.
13037: #
13038: # (WA) BUFFER SIZE IN CHARACTERS
13039: # JSR ALOBF CALL TO CREATE BUFFER
13040: # (XR) BCBLK PTR
13041: # (WA,WB) DESTROYED
13042: #
13043: alobf: #prc # entry point
13044: movl r6,r7 # hang onto allocation size
13045: movab 3+(4*bfsi$)(r6),r6 # get total block size
13046: bicl2 $3,r6
13047: cmpl r6,mxlen # check for maxlen exceeded
13048: bgequ alb01
13049: addl2 $4*bcsi$,r6 # add in allocation for bcblk
13050: jsb alloc # allocate frame
13051: movl $b$bct,(r9) # set type
13052: clrl 4*idval(r9) # no id yet
13053: clrl 4*bclen(r9) # no defined length
13054: movl r10,r6 # save xl
13055: movl r9,r10 # copy bcblk ptr
13056: addl2 $4*bcsi$,r10 # bias past partially built bcblk
13057: movl $b$bft,(r10) # set bfblk type word
13058: movl r7,4*bfalc(r10) # set allocated size
13059: movl r10,4*bcbuf(r9) # set pointer in bcblk
13060: clrl 4*bfchr(r10) # clear first word (null pad)
13061: movl r6,r10 # restore entry xl
13062: rsb # return to caller
13063: #
13064: # HERE FOR MXLEN EXCEEDED
13065: #
13066: alb01: jmp er_274 # requested buffer allocation exceeds mxlen
13067: #enp # end procedure alobf
13068: #page
13069: #
13070: # ALOCS -- ALLOCATE STRING BLOCK
13071: #
13072: # ALOCS IS USED TO BUILD A FRAME FOR A STRING BLOCK INTO
13073: # WHICH THE ACTUAL CHARACTERS ARE PLACED BY THE CALLER.
13074: # ALL STRINGS ARE CREATED WITH A CALL TO ALOCS (THE
13075: # EXCEPTIONS OCCUR IN TRIMR AND S$RPL PROCEDURES).
13076: #
13077: # (WA) LENGTH OF STRING TO BE ALLOCATED
13078: # JSR ALOCS CALL TO ALLOCATE SCBLK
13079: # (XR) POINTER TO RESULTING SCBLK
13080: # (WA) DESTROYED
13081: # (WC) CHARACTER COUNT (ENTRY VALUE OF WA)
13082: #
13083: # THE RESULTING SCBLK HAS THE TYPE WORD AND THE LENGTH
13084: # FILLED IN AND THE LAST WORD IS CLEARED TO ZERO CHARACTERS
13085: # TO ENSURE CORRECT RIGHT PADDING OF THE FINAL WORD.
13086: #
13087: alocs: #prc # entry point
13088: cmpl r6,kvmxl # jump if length exceeeds maxlength
13089: bgtru alcs2
13090: movl r6,r8 # else copy length
13091: movab 3+(4*scsi$)(r6),r6 # compute length of scblk in bytes
13092: bicl2 $3,r6
13093: movl dnamp,r9 # point to next available location
13094: addl2 r6,r9 # point past block
13095: bvc 0f
13096: jmp alcs0
13097: 0:
13098: cmpl r9,dname # jump if there is room
13099: blequ alcs1
13100: #
13101: # INSUFFICIENT MEMORY
13102: #
13103: alcs0: clrl r9 # else clear garbage xr value
13104: jsb alloc # and use standard allocator
13105: addl2 r6,r9 # point past end of block to merge
13106: #
13107: # MERGE HERE WITH XR POINTING BEYOND NEW BLOCK
13108: #
13109: alcs1: movl r9,dnamp # set updated storage pointer
13110: clrl -(r9) # store zero chars in last word
13111: subl2 $4,r6 # decrement length
13112: subl2 r6,r9 # point back to start of block
13113: movl $b$scl,(r9) # set type word
13114: movl r8,4*sclen(r9) # store length in chars
13115: rsb # return to alocs caller
13116: #
13117: # COME HERE IF STRING IS TOO LONG
13118: #
13119: alcs2: jmp er_205 # string length exceeds value of maxlngth keyword
13120: #enp # end procedure alocs
13121: #page
13122: #
13123: # ALOST -- ALLOCATE SPACE IN STATIC REGION
13124: #
13125: # (WA) LENGTH REQUIRED IN BYTES
13126: # JSR ALOST CALL TO ALLOCATE SPACE
13127: # (XR) POINTER TO ALLOCATED BLOCK
13128: # (WB) DESTROYED
13129: #
13130: # NOTE THAT THE CODING ENSURES THAT THE RESULTING VALUE
13131: # OF STATE IS ALWAYS LESS THAN DNAMB. THIS FACT IS USED
13132: # IN TESTING A VARIABLE NAME FOR BEING IN THE STATIC REGION
13133: #
13134: alost: #prc # entry point
13135: #
13136: # MERGE BACK HERE AFTER ALLOCATING NEW CHUNK
13137: #
13138: alst1: movl state,r9 # point to current end of area
13139: addl2 r6,r9 # point beyond proposed block
13140: bvc 0f
13141: jmp alst2
13142: 0:
13143: cmpl r9,dnamb # jump if overlap with dynamic area
13144: bgequ alst2
13145: movl r9,state # else store new pointer
13146: subl2 r6,r9 # point back to start of block
13147: rsb # return to alost caller
13148: #
13149: # HERE IF NO ROOM, PREPARE TO MOVE DYNAMIC STORAGE UP
13150: #
13151: alst2: movl r6,alsta # save wa
13152: cmpl r6,$4*e$sts # skip if requested chunk is large
13153: bgequ alst3
13154: movl $4*e$sts,r6 # else set to get large enough chunk
13155: #
13156: # HERE WITH AMOUNT TO MOVE UP IN WA
13157: #
13158: alst3: jsb alloc # allocate block to ensure room
13159: movl r9,dnamp # and delete it
13160: movl r6,r7 # copy move up amount
13161: jsb gbcol # call gbcol to move dynamic area up
13162: movl alsta,r6 # restore wa
13163: jmp alst1 # loop back to try again
13164: #enp # end procedure alost
13165: #page
13166: #
13167: # APNDB -- APPEND STRING TO BUFFER
13168: #
13169: # THIS ROUTINE IS USED BY BUFFER HANDLING ROUTINES TO
13170: # APPEND DATA TO AN EXISTING BFBLK.
13171: #
13172: # (XR) EXISTING BCBLK TO BE APPENDED
13173: # (XL) CONVERTABLE TO STRING
13174: # JSR APNDB CALL TO APPEND TO BUFFER
13175: # PPM LOC THREAD IF (XL) CANT BE CONVERTED
13176: # PPM LOC IF NOT ENOUGH ROOM
13177: # (WA,WB) DESTROYED
13178: #
13179: # IF MORE CHARACTERS ARE SPECIFIED THAN CAN BE INSERTED,
13180: # THEN NO ACTION IS TAKEN AND THE SECOND RETURN IS TAKEN.
13181: #
13182: apndb: #prc # entry point
13183: movl 4*bclen(r9),r6 # load offset to insert
13184: clrl r7 # replace section is null
13185: jsb insbf # call to insert at end
13186: .long apn01 # convert error
13187: .long apn02 # no room
13188: addl2 $4*2,(sp) # return to caller
13189: rsb
13190: #
13191: # HERE TO TAKE CONVERT FAILURE EXIT
13192: #
13193: apn01: movl (sp)+,r11 # return to caller alternate
13194: jmp *(r11)+
13195: #
13196: # HERE FOR NO FIT EXIT
13197: #
13198: apn02: addl3 $4*1,(sp)+,r11 # alternate exit to caller
13199: jmp *(r11)+
13200: #enp # end procedure apndb
13201: #page
13202: #
13203: # ARITH -- FETCH ARITHMETIC OPERANDS
13204: #
13205: # ARITH IS USED BY FUNCTIONS AND OPERATORS WHICH EXPECT
13206: # TWO NUMERIC ARGUMENTS (OPERANDS) WHICH MUST BOTH BE
13207: # INTEGER OR BOTH BE REAL. ARITH FETCHES TWO ARGUMENTS FROM
13208: # THE STACK AND PERFORMS ANY NECESSARY CONVERSIONS.
13209: #
13210: # 1(XS) FIRST ARGUMENT (LEFT OPERAND)
13211: # 0(XS) SECOND ARGUMENT (RIGHT OPERAND)
13212: # JSR ARITH CALL TO FETCH NUMERIC ARGUMENTS
13213: # PPM LOC TRANSFER LOC FOR OPND 1 NON-NUMERIC
13214: # PPM LOC TRANSFER LOC FOR OPND 2 NON-NUMERIC
13215: # PPM LOC TRANSFER LOC FOR REAL OPERANDS
13216: #
13217: # FOR INTEGER ARGS, CONTROL RETURNS PAST THE PARAMETERS
13218: #
13219: # (IA) LEFT OPERAND VALUE
13220: # (XR) PTR TO ICBLK FOR LEFT OPERAND
13221: # (XL) PTR TO ICBLK FOR RIGHT OPERAND
13222: # (XS) POPPED TWICE
13223: # (WA,WB,RA) DESTROYED
13224: #
13225: # FOR REAL ARGUMENTS, CONTROL RETURNS TO THE LOCATION
13226: # SPECIFIED BY THE THIRD PARAMETER.
13227: #
13228: # (RA) LEFT OPERAND VALUE
13229: # (XR) PTR TO RCBLK FOR LEFT OPERAND
13230: # (XL) PTR TO RCBLK FOR RIGHT OPERAND
13231: # (WA,WB,WC) DESTROYED
13232: # (XS) POPPED TWICE
13233: #page
13234: #
13235: # ARITH (CONTINUED)
13236: #
13237: # ENTRY POINT
13238: #
13239: .data 1
13240: arith_s: .long 0
13241: .text 0
13242: arith: movl (sp)+,arith_s # entry point
13243: movl (sp)+,r10 # load right operand
13244: movl (sp)+,r9 # load left operand
13245: movl (r10),r6 # get right operand type word
13246: cmpl r6,$b$icl # jump if integer
13247: beqlu arth1
13248: cmpl r6,$b$rcl # jump if real
13249: beqlu arth4
13250: movl r9,-(sp) # else replace left arg on stack
13251: movl r10,r9 # copy left arg pointer
13252: jsb gtnum # convert to numeric
13253: .long arth6 # jump if unconvertible
13254: movl r9,r10 # else copy converted result
13255: movl (r10),r6 # get right operand type word
13256: movl (sp)+,r9 # reload left argument
13257: cmpl r6,$b$rcl # jump if right arg is real
13258: beqlu arth4
13259: #
13260: # HERE IF RIGHT ARG IS AN INTEGER
13261: #
13262: arth1: cmpl (r9),$b$icl # jump if left arg not integer
13263: bnequ arth3
13264: #
13265: # EXIT FOR INTEGER CASE
13266: #
13267: arth2: movl 4*icval(r9),r5 # load left operand value
13268: addl3 $4*3,arith_s,r11 # return to arith caller
13269: jmp (r11)
13270: #
13271: # HERE FOR RIGHT OPERAND INTEGER, LEFT OPERAND NOT
13272: #
13273: arth3: jsb gtnum # convert left arg to numeric
13274: .long arth7 # jump if not convertible
13275: cmpl r6,$b$icl # jump back if integer-integer
13276: beqlu arth2
13277: #
13278: # HERE WE MUST CONVERT REAL-INTEGER TO REAL-REAL
13279: #
13280: movl r9,-(sp) # put left arg back on stack
13281: movl 4*icval(r10),r5 # load right argument value
13282: cvtlf r5,r2 # convert to real
13283: jsb rcbld # get real block for right arg, merge
13284: movl r9,r10 # copy right arg ptr
13285: movl (sp)+,r9 # load left argument
13286: jmp arth5 # merge for real-real case
13287: #page
13288: #
13289: # ARITH (CONTINUED)
13290: #
13291: # HERE IF RIGHT ARGUMENT IS REAL
13292: #
13293: arth4: cmpl (r9),$b$rcl # jump if left arg real
13294: beqlu arth5
13295: jsb gtrea # else convert to real
13296: .long arth7 # error if unconvertible
13297: #
13298: # HERE FOR REAL-REAL
13299: #
13300: arth5: movf 4*rcval(r9),r2 # load left operand value
13301: addl3 $4*2,arith_s,r11 # take real-real exit
13302: jmp *(r11)+
13303: #
13304: # HERE FOR ERROR CONVERTING RIGHT ARGUMENT
13305: #
13306: arth6: addl2 $4,sp # pop unwanted left arg
13307: addl3 $4*1,arith_s,r11 # take appropriate error exit
13308: jmp *(r11)+
13309: #
13310: # HERE FOR ERROR CONVERTING LEFT OPERAND
13311: #
13312: arth7: movl arith_s,r11 # take appropriate error return
13313: jmp *(r11)+
13314: #enp # end procedure arith
13315: #page
13316: #
13317: # ASIGN -- PERFORM ASSIGNMENT
13318: #
13319: # ASIGN PERFORMS THE ASSIGNMENT OF A VALUE TO A VARIABLE
13320: # WITH APPROPRIATE CHECKS FOR OUTPUT ASSOCIATIONS AND
13321: # VALUE TRACE ASSOCIATIONS WHICH ARE EXECUTED AS REQUIRED.
13322: # ASIGN ALSO HANDLES THE SPECIAL CASES OF ASSIGNMENT TO
13323: # PATTERN AND EXPRESSION VARIABLES.
13324: #
13325: # (WB) VALUE TO BE ASSIGNED
13326: # (XL) BASE POINTER FOR VARIABLE
13327: # (WA) OFFSET FOR VARIABLE
13328: # JSR ASIGN CALL TO ASSIGN VALUE TO VARIABLE
13329: # PPM LOC TRANSFER LOC FOR FAILURE
13330: # (XR,XL,WA,WB,WC) DESTROYED
13331: # (RA) DESTROYED
13332: #
13333: # FAILURE OCCURS IF THE EVALUATION OF AN EXPRESSION
13334: # ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS.
13335: #
13336: asign: #prc # entry point (recursive)
13337: #
13338: # MERGE BACK HERE TO ASSIGN RESULT TO EXPRESSION VARIABLE.
13339: #
13340: asg01: addl2 r6,r10 # point to variable value
13341: movl (r10),r9 # load variable value
13342: cmpl (r9),$b$trt # jump if trapped
13343: beqlu asg02
13344: movl r7,(r10) # else perform assignment
13345: clrl r10 # clear garbage value in xl
13346: addl2 $4*1,(sp) # and return to asign caller
13347: rsb
13348: #
13349: # HERE IF VALUE IS TRAPPED
13350: #
13351: asg02: subl2 r6,r10 # restore name base
13352: cmpl r9,$trbkv # jump if keyword variable
13353: bnequ 0f
13354: jmp asg14
13355: 0:
13356: cmpl r9,$trbev # jump if not expression variable
13357: bnequ asg04
13358: #
13359: # HERE FOR ASSIGNMENT TO EXPRESSION VARIABLE
13360: #
13361: movl 4*evexp(r10),r9 # point to expression
13362: movl r7,-(sp) # store value to assign on stack
13363: movl $num01,r7 # set for evaluation by name
13364: jsb evalx # evaluate expression by name
13365: .long asg03 # jump if evaluation fails
13366: movl (sp)+,r7 # else reload value to assign
13367: jmp asg01 # loop back to perform assignment
13368: #page
13369: #
13370: # ASIGN (CONTINUED)
13371: #
13372: # HERE FOR FAILURE DURING EXPRESSION EVALUATION
13373: #
13374: asg03: addl2 $4,sp # remove stacked value entry
13375: movl (sp)+,r11 # take failure exit
13376: jmp *(r11)+
13377: #
13378: # HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
13379: #
13380: asg04: movl r9,-(sp) # save ptr to first trblk
13381: #
13382: # LOOP TO CHASE DOWN TRBLK CHAIN AND ASSIGN VALUE AT END
13383: #
13384: asg05: movl r9,r8 # save ptr to this trblk
13385: movl 4*trnxt(r9),r9 # point to next trblk
13386: cmpl (r9),$b$trt # loop back if another trblk
13387: beqlu asg05
13388: movl r8,r9 # else point back to last trblk
13389: movl r7,4*trval(r9) # store value at end of chain
13390: movl (sp)+,r9 # restore ptr to first trblk
13391: #
13392: # LOOP TO PROCESS TRBLK ENTRIES ON CHAIN
13393: #
13394: asg06: movl 4*trtyp(r9),r7 # load type code of trblk
13395: cmpl r7,$trtvl # jump if value trace
13396: beqlu asg08
13397: cmpl r7,$trtou # jump if output association
13398: beqlu asg10
13399: #
13400: # HERE TO MOVE TO NEXT TRBLK ON CHAIN
13401: #
13402: asg07: movl 4*trnxt(r9),r9 # point to next trblk on chain
13403: cmpl (r9),$b$trt # loop back if another trblk
13404: beqlu asg06
13405: addl2 $4*1,(sp) # else end of chain, return to caller
13406: rsb
13407: #
13408: # HERE TO PROCESS VALUE TRACE
13409: #
13410: asg08: tstl kvtra # ignore value trace if trace off
13411: beqlu asg07
13412: decl kvtra # else decrement trace count
13413: tstl 4*trfnc(r9) # jump if print trace
13414: beqlu asg09
13415: jsb trxeq # else execute function trace
13416: jmp asg07 # and loop back
13417: #page
13418: #
13419: # ASIGN (CONTINUED)
13420: #
13421: # HERE FOR PRINT TRACE
13422: #
13423: asg09: jsb prtsn # print statement number
13424: jsb prtnv # print name = value
13425: jmp asg07 # loop back for next trblk
13426: #
13427: # HERE FOR OUTPUT ASSOCIATION
13428: #
13429: asg10: tstl kvoup # ignore output assoc if output off
13430: beqlu asg07
13431: movl r9,r10 # else copy trblk pointer
13432: movl 4*trval(r8),-(sp)# stack value to output (sgd01)
13433: jsb gtstg # convert to string
13434: .long asg12 # get datatype name if unconvertible
13435: #
13436: # MERGE WITH STRING FOR OUTPUT
13437: #
13438: asg11: movl 4*trfpt(r10),r6 # fcblk ptr
13439: beqlu asg13 # jump if standard output file
13440: #
13441: # HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE
13442: #
13443: jsb sysou # call system output routine
13444: .long er_206 # output caused file overflow
13445: .long er_207 # output caused non-recoverable error
13446: addl2 $4*1,(sp) # else all done, return to caller
13447: rsb
13448: #
13449: # IF NOT PRINTABLE, GET DATATYPE NAME INSTEAD
13450: #
13451: asg12: jsb dtype # call datatype routine
13452: jmp asg11 # merge
13453: #
13454: # HERE TO PRINT A STRING ON THE PRINTER
13455: #
13456: asg13: jsb prtst # print string value
13457: cmpl 4*trter(r10),$v$ter # jump if terminal output
13458: bnequ 0f
13459: jmp asg20
13460: 0:
13461: jsb prtnl # end of line
13462: addl2 $4*1,(sp) # return to caller
13463: rsb
13464: #page
13465: #
13466: # ASIGN (CONTINUED)
13467: #
13468: # HERE FOR KEYWORD ASSIGNMENT
13469: #
13470: asg14: movl 4*kvnum(r10),r10# load keyword number
13471: cmpl r10,$k$etx # jump if errtext
13472: bnequ 0f
13473: jmp asg19
13474: 0:
13475: movl r7,r9 # copy value to be assigned
13476: jsb gtint # convert to integer
13477: .long er_208 # keyword value assigned is not integer
13478: movl 4*icval(r9),r5 # else load value
13479: cmpl r10,$k$stl # jump if special case of stlimit
13480: beqlu asg16
13481: movl r5,r6 # else get addr integer, test ovflow
13482: bgeq 0f
13483: jmp asg18
13484: 0:
13485: cmpl r6,mxlen # fail if too large
13486: bgequ asg18
13487: cmpl r10,$k$ert # jump if special case of errtype
13488: beqlu asg17
13489: cmpl r10,$k$pfl # jump if special case of profile
13490: beqlu asg21
13491: cmpl r10,$k$p$$ # jump unless protected
13492: blssu asg15
13493: jmp er_209 # keyword in assignment is protected
13494: #
13495: # HERE TO DO ASSIGNMENT IF NOT PROTECTED
13496: #
13497: asg15: movl r6,l^kvabe(r10) # store new value
13498: addl2 $4*1,(sp) # return to asign caller
13499: rsb
13500: #
13501: # HERE FOR SPECIAL CASE OF STLIMIT
13502: #
13503: # SINCE STCOUNT IS MAINTAINED AS (STLIMIT-STCOUNT)
13504: # IT IS ALSO NECESSARY TO MODIFY STCOUNT APPROPRIATELY.
13505: #
13506: asg16: subl2 kvstl,r5 # subtract old limit
13507: addl2 kvstc,r5 # add old counter
13508: movl r5,kvstc # store new counter value
13509: movl 4*icval(r9),r5 # reload new limit value
13510: movl r5,kvstl # store new limit value
13511: addl2 $4*1,(sp) # return to asign caller
13512: rsb
13513: #
13514: # HERE FOR SPECIAL CASE OF ERRTYPE
13515: #
13516: asg17: cmpl r6,$nini9 # ok to signal if in range
13517: bgtru 0f
13518: jmp error
13519: 0:
13520: #
13521: # HERE IF VALUE ASSIGNED IS OUT OF RANGE
13522: #
13523: asg18: jmp er_210 # keyword value assigned is negative or too large
13524: #
13525: # HERE FOR SPECIAL CASE OF ERRTEXT
13526: #
13527: asg19: movl r7,-(sp) # stack value
13528: jsb gtstg # convert to string
13529: .long er_211 # value assigned to keyword errtext not a string
13530: movl r9,r$etx # make assignment
13531: addl2 $4*1,(sp) # return to caller
13532: rsb
13533: #
13534: # PRINT STRING TO TERMINAL
13535: #
13536: asg20: jsb prttr # print
13537: addl2 $4*1,(sp) # return
13538: rsb
13539: #
13540: # HERE FOR KEYWORD PROFILE
13541: #
13542: asg21: cmpl r6,$num02 # moan if not 0,1, or 2
13543: bgtru asg18
13544: tstl r6 # just assign if zero
13545: beqlu asg15
13546: tstl pfdmp # branch if first assignment
13547: beqlu asg22
13548: cmpl r6,pfdmp # also if same value as before
13549: beqlu asg23
13550: jmp er_268 # inconsistent value assigned to keyword profile
13551: #
13552: asg22: movl r6,pfdmp # note value on first assignment
13553: asg23: jsb systm # get the time
13554: movl r5,pfstm # fudge some kind of start time
13555: jmp asg15 # and go assign
13556: #enp # end procedure asign
13557: #page
13558: #
13559: # ASINP -- ASSIGN DURING PATTERN MATCH
13560: #
13561: # ASINP IS LIKE ASIGN AND HAS A SIMILAR CALLING SEQUENCE
13562: # AND EFFECT. THE DIFFERENCE IS THAT THE GLOBAL PATTERN
13563: # VARIABLES ARE SAVED AND RESTORED IF REQUIRED.
13564: #
13565: # (XL) BASE POINTER FOR VARIABLE
13566: # (WA) OFFSET FOR VARIABLE
13567: # (WB) VALUE TO BE ASSIGNED
13568: # JSR ASINP CALL TO ASSIGN VALUE TO VARIABLE
13569: # PPM LOC TRANSFER LOC IF FAILURE
13570: # (XR,XL) DESTROYED
13571: # (WA,WB,WC,RA) DESTROYED
13572: #
13573: asinp: #prc # entry point, recursive
13574: addl2 r6,r10 # point to variable
13575: movl (r10),r9 # load current contents
13576: cmpl (r9),$b$trt # jump if trapped
13577: beqlu asnp1
13578: movl r7,(r10) # else perform assignment
13579: clrl r10 # clear garbage value in xl
13580: addl2 $4*1,(sp) # return to asinp caller
13581: rsb
13582: #
13583: # HERE IF VARIABLE IS TRAPPED
13584: #
13585: asnp1: subl2 r6,r10 # restore base pointer
13586: movl pmssl,-(sp) # stack subject string length
13587: movl pmhbs,-(sp) # stack history stack base ptr
13588: movl r$pms,-(sp) # stack subject string pointer
13589: movl pmdfl,-(sp) # stack dot flag
13590: jsb asign # call full-blown assignment routine
13591: .long asnp2 # jump if failure
13592: movl (sp)+,pmdfl # restore dot flag
13593: movl (sp)+,r$pms # restore subject string pointer
13594: movl (sp)+,pmhbs # restore history stack base pointer
13595: movl (sp)+,pmssl # restore subject string length
13596: addl2 $4*1,(sp) # return to asinp caller
13597: rsb
13598: #
13599: # HERE IF FAILURE IN ASIGN CALL
13600: #
13601: asnp2: movl (sp)+,pmdfl # restore dot flag
13602: movl (sp)+,r$pms # restore subject string pointer
13603: movl (sp)+,pmhbs # restore history stack base pointer
13604: movl (sp)+,pmssl # restore subject string length
13605: movl (sp)+,r11 # take failure exit
13606: jmp *(r11)+
13607: #enp # end procedure asinp
13608: #page
13609: #
13610: # BLKLN -- DETERMINE LENGTH OF BLOCK
13611: #
13612: # BLKLN DETERMINES THE LENGTH OF A BLOCK IN DYNAMIC STORE.
13613: #
13614: # (WA) FIRST WORD OF BLOCK
13615: # (XR) POINTER TO BLOCK
13616: # JSR BLKLN CALL TO GET BLOCK LENGTH
13617: # (WA) LENGTH OF BLOCK IN BYTES
13618: # (XL) DESTROYED
13619: #
13620: # BLKLN IS USED BY THE GARBAGE COLLECTOR AND IS NOT
13621: # PERMITTED TO CALL GBCOL DIRECTLY OR INDIRECTLY.
13622: #
13623: # THE FIRST WORD STORED IN THE BLOCK (I.E. AT XR) MAY
13624: # BE ANYTHING, BUT THE CONTENTS OF WA MUST BE CORRECT.
13625: #
13626: blkln: #prc # entry point
13627: movl r6,r10 # copy first word
13628: movzwl -2(r10),r10 # get entry id (bl$xx)
13629: casel r10,$0,$bl$$$ # switch on block type
13630: 5:
13631: .word bln01-5b # arblk
13632: .word bln04-5b # bcblk
13633: .word bln01-5b # cdblk
13634: .word bln01-5b # exblk
13635: .word bln07-5b # icblk
13636: .word bln03-5b # nmblk
13637: .word bln02-5b # p0blk
13638: .word bln03-5b # p1blk
13639: .word bln04-5b # p2blk
13640: .word bln09-5b # rcblk
13641: .word bln10-5b # scblk
13642: .word bln02-5b # seblk
13643: .word bln01-5b # tbblk
13644: .word bln01-5b # vcblk
13645: .word bln00-5b
13646: .word bln00-5b
13647: .word bln08-5b # pdblk
13648: .word bln05-5b # trblk
13649: .word bln11-5b # bfblk
13650: .word bln00-5b
13651: .word bln00-5b
13652: .word bln06-5b # ctblk
13653: .word bln01-5b # dfblk
13654: .word bln01-5b # efblk
13655: .word bln03-5b # evblk
13656: .word bln05-5b # ffblk
13657: .word bln03-5b # kvblk
13658: .word bln01-5b # pfblk
13659: .word bln04-5b # teblk
13660: #esw # end of jump table on block type
13661: #page
13662: #
13663: # BLKLN (CONTINUED)
13664: #
13665: # HERE FOR BLOCKS WITH LENGTH IN SECOND WORD
13666: #
13667: bln00: movl 4*1(r9),r6 # load length
13668: rsb # return to blkln caller
13669: #
13670: # HERE FOR LENGTH IN THIRD WORD (AR,CD,DF,EF,EX,PF,TB,VC)
13671: #
13672: bln01: movl 4*2(r9),r6 # load length from third word
13673: rsb # return to blkln caller
13674: #
13675: # HERE FOR TWO WORD BLOCKS (P0,SE)
13676: #
13677: bln02: movl $4*num02,r6 # load length (two words)
13678: rsb # return to blkln caller
13679: #
13680: # HERE FOR THREE WORD BLOCKS (NM,P1,EV,KV)
13681: #
13682: bln03: movl $4*num03,r6 # load length (three words)
13683: rsb # return to blkln caller
13684: #
13685: # HERE FOR FOUR WORD BLOCKS (P2,TE,BC)
13686: #
13687: bln04: movl $4*num04,r6 # load length (four words)
13688: rsb # return to blkln caller
13689: #
13690: # HERE FOR FIVE WORD BLOCKS (FF,TR)
13691: #
13692: bln05: movl $4*num05,r6 # load length
13693: rsb # return to blkln caller
13694: #page
13695: #
13696: # BLKLN (CONTINUED)
13697: #
13698: # HERE FOR CTBLK
13699: #
13700: bln06: movl $4*ctsi$,r6 # set size of ctblk
13701: rsb # return to blkln caller
13702: #
13703: # HERE FOR ICBLK
13704: #
13705: bln07: movl $4*icsi$,r6 # set size of icblk
13706: rsb # return to blkln caller
13707: #
13708: # HERE FOR PDBLK
13709: #
13710: bln08: movl 4*pddfp(r9),r10 # point to dfblk
13711: movl 4*dfpdl(r10),r6 # load pdblk length from dfblk
13712: rsb # return to blkln caller
13713: #
13714: # HERE FOR RCBLK
13715: #
13716: bln09: movl $4*rcsi$,r6 # set size of rcblk
13717: rsb # return to blkln caller
13718: #
13719: # HERE FOR SCBLK
13720: #
13721: bln10: movl 4*sclen(r9),r6 # load length in characters
13722: movab 3+(4*scsi$)(r6),r6 # calculate length in bytes
13723: bicl2 $3,r6
13724: rsb # return to blkln caller
13725: #
13726: # HERE FOR BFBLK
13727: #
13728: bln11: movl 4*bfalc(r9),r6 # get allocation in bytes
13729: movab 3+(4*bfsi$)(r6),r6 # calculate length in bytes
13730: bicl2 $3,r6
13731: rsb # return to blkln caller
13732: #enp # end procedure blkln
13733: #page
13734: #
13735: # COPYB -- COPY A BLOCK
13736: #
13737: # (XS) BLOCK TO BE COPIED
13738: # JSR COPYB CALL TO COPY BLOCK
13739: # PPM LOC RETURN IF BLOCK HAS NO IDVAL FIELD
13740: # NORMAL RETURN IF IDVAL FIELD
13741: # (XR) COPY OF BLOCK
13742: # (XS) POPPED
13743: # (XL,WA,WB,WC) DESTROYED
13744: #
13745: .data 1
13746: copyb_s: .long 0
13747: .text 0
13748: copyb: movl (sp)+,copyb_s # entry point
13749: movl (sp),r9 # load argument
13750: cmpl r9,$nulls # return argument if it is null
13751: bnequ 0f
13752: jmp cop10
13753: 0:
13754: movl (r9),r6 # else load type word
13755: movl r6,r7 # copy type word
13756: jsb blkln # get length of argument block
13757: movl r9,r10 # copy pointer
13758: jsb alloc # allocate block of same size
13759: movl r9,(sp) # store pointer to copy
13760: jsb sbmvw # copy contents of old block to new
13761: movl (sp),r9 # reload pointer to start of copy
13762: cmpl r7,$b$tbt # jump if table
13763: beqlu cop05
13764: cmpl r7,$b$vct # jump if vector
13765: beqlu cop01
13766: cmpl r7,$b$pdt # jump if program defined
13767: beqlu cop01
13768: cmpl r7,$b$bct # jump if buffer
13769: bnequ 0f
13770: jmp cop11
13771: 0:
13772: cmpl r7,$b$art # return copy if not array
13773: beqlu 0f
13774: jmp cop10
13775: 0:
13776: #
13777: # HERE FOR ARRAY (ARBLK)
13778: #
13779: addl2 4*arofs(r9),r9 # point to prototype field
13780: jmp cop02 # jump to merge
13781: #
13782: # HERE FOR VECTOR, PROGRAM DEFINED
13783: #
13784: cop01: addl2 $4*pdfld,r9 # point to pdfld = vcvls
13785: #
13786: # MERGE HERE FOR ARBLK, VCBLK, PDBLK TO DELETE TRAP
13787: # BLOCKS FROM ALL VALUE FIELDS (THE COPY IS UNTRAPPED)
13788: #
13789: cop02: movl (r9),r10 # load next pointer
13790: #
13791: # LOOP TO GET VALUE AT END OF TRBLK CHAIN
13792: #
13793: cop03: cmpl (r10),$b$trt # jump if not trapped
13794: bnequ cop04
13795: movl 4*trval(r10),r10# else point to next value
13796: jmp cop03 # and loop back
13797: #page
13798: #
13799: # COPYB (CONTINUED)
13800: #
13801: # HERE WITH UNTRAPPED VALUE IN XL
13802: #
13803: cop04: movl r10,(r9)+ # store real value, bump pointer
13804: cmpl r9,dnamp # loop back if more to go
13805: bnequ cop02
13806: jmp cop09 # else jump to exit
13807: #
13808: # HERE TO COPY A TABLE
13809: #
13810: cop05: clrl 4*idval(r9) # zero id to stop dump blowing up
13811: movl $4*tesi$,r6 # set size of teblk
13812: movl $4*tbbuk,r8 # set initial offset
13813: #
13814: # LOOP THROUGH BUCKETS IN TABLE
13815: #
13816: cop06: movl (sp),r9 # load table pointer
13817: cmpl r8,4*tblen(r9) # jump to exit if all done
13818: beqlu cop09
13819: addl2 r8,r9 # else point to next bucket header
13820: addl2 $4,r8 # bump offset
13821: subl2 $4*tenxt,r9 # subtract link offset to merge
13822: #
13823: # LOOP THROUGH TEBLKS ON ONE CHAIN
13824: #
13825: cop07: movl 4*tenxt(r9),r10 # load pointer to next teblk
13826: movl (sp),4*tenxt(r9)# set end of chain pointer in case
13827: cmpl (r10),$b$tbt # back for next bucket if chain end
13828: beqlu cop06
13829: movl r9,-(sp) # else stack ptr to previous block
13830: movl $4*tesi$,r6 # set size of teblk
13831: jsb alloc # allocate new teblk
13832: movl r9,r7 # save ptr to new teblk
13833: jsb sbmvw # copy old teblk to new teblk
13834: movl r7,r9 # restore pointer to new teblk
13835: movl (sp)+,r10 # restore pointer to previous block
13836: movl r9,4*tenxt(r10) # link new block to previous
13837: movl r9,r10 # copy pointer to new block
13838: #
13839: # LOOP TO SET REAL VALUE AFTER REMOVING TRAP CHAIN
13840: #
13841: cop08: movl 4*teval(r10),r10# load value
13842: cmpl (r10),$b$trt # loop back if trapped
13843: beqlu cop08
13844: movl r10,4*teval(r9) # store untrapped value in teblk
13845: jmp cop07 # back for next teblk
13846: #
13847: # COMMON EXIT POINT
13848: #
13849: cop09: movl (sp)+,r9 # load pointer to block
13850: addl3 $4*1,copyb_s,r11 # return
13851: jmp (r11)
13852: #
13853: # ALTERNATIVE RETURN
13854: #
13855: cop10: movl copyb_s,r11 # return
13856: jmp *(r11)+
13857: #page
13858: #
13859: # HERE TO COPY BUFFER
13860: #
13861: cop11: movl 4*bcbuf(r9),r10 # get bfblk ptr
13862: movl 4*bfalc(r10),r6 # get allocation
13863: movab 3+(4*bfsi$)(r6),r6 # set total size
13864: bicl2 $3,r6
13865: movl r9,r10 # save bcblk ptr
13866: jsb alloc # allocate bfblk
13867: movl 4*bcbuf(r10),r7 # get old bfblk
13868: movl r9,4*bcbuf(r10) # set pointer to new bfblk
13869: movl r7,r10 # point to old bfblk
13870: jsb sbmvw # copy bfblk too
13871: clrl r10 # clear rubbish ptr
13872: jmp cop09 # branch to exit
13873: #enp # end procedure copyb
13874: #
13875: # CDGCG -- GENERATE CODE FOR COMPLEX GOTO
13876: #
13877: # USED BY CMPIL TO PROCESS COMPLEX GOTO TREE
13878: #
13879: # (WB) MUST BE COLLECTABLE
13880: # (XR) EXPRESSION POINTER
13881: # JSR CDGCG CALL TO GENERATE COMPLEX GOTO
13882: # (XL,XR,WA) DESTROYED
13883: #
13884: cdgcg: #prc # entry point
13885: movl 4*cmopn(r9),r10 # get unary goto operator
13886: movl 4*cmrop(r9),r9 # point to goto operand
13887: cmpl r10,$opdvd # jump if direct goto
13888: beqlu cdgc2
13889: jsb cdgnm # generate opnd by name if not direct
13890: #
13891: # RETURN POINT
13892: #
13893: cdgc1: movl r10,r6 # goto operator
13894: jsb cdwrd # generate it
13895: rsb # return to caller
13896: #
13897: # DIRECT GOTO
13898: #
13899: cdgc2: jsb cdgvl # generate operand by value
13900: jmp cdgc1 # merge to return
13901: #enp # end procedure cdgcg
13902: #page
13903: #
13904: # CDGEX -- BUILD EXPRESSION BLOCK
13905: #
13906: # CDGEX IS PASSED A POINTER TO AN EXPRESSION TREE (SEE
13907: # EXPAN) AND RETURNS AN EXPRESSION (SEBLK OR EXBLK).
13908: #
13909: # (WC) SOME COLLECTABLE VALUE
13910: # (WB) INTEGER IN RANGE 0 LE X LE MXLEN
13911: # (XL) PTR TO EXPRESSION TREE
13912: # JSR CDGEX CALL TO BUILD EXPRESSION
13913: # (XR) PTR TO SEBLK OR EXBLK
13914: # (XL,WA,WB) DESTROYED
13915: #
13916: cdgex: #prc # entry point, recursive
13917: cmpl (r10),$b$vr$ # jump if not variable
13918: blequ cdgx1
13919: #
13920: # HERE FOR NATURAL VARIABLE, BUILD SEBLK
13921: #
13922: movl $4*sesi$,r6 # set size of seblk
13923: jsb alloc # allocate space for seblk
13924: movl $b$sel,(r9) # set type word
13925: movl r10,4*sevar(r9) # store vrblk pointer
13926: rsb # return to cdgex caller
13927: #
13928: # HERE IF NOT VARIABLE, BUILD EXBLK
13929: #
13930: cdgx1: movl r10,r9 # copy tree pointer
13931: movl r8,-(sp) # save wc
13932: movl cwcof,r10 # save current offset
13933: movl (r9),r6 # get type word
13934: cmpl r6,$b$cmt # call by value if not cmblk
13935: bnequ cdgx2
13936: cmpl 4*cmtyp(r9),$c$$nm # jump if cmblk only by value
13937: bgequ cdgx2
13938: #page
13939: #
13940: # CDGEX (CONTINUED)
13941: #
13942: # HERE IF EXPRESSION CAN BE EVALUATED BY NAME
13943: #
13944: jsb cdgnm # generate code by name
13945: movl $ornm$,r6 # load return by name word
13946: jmp cdgx3 # merge with value case
13947: #
13948: # HERE IF EXPRESSION CAN ONLY BE EVALUATED BY VALUE
13949: #
13950: cdgx2: jsb cdgvl # generate code by value
13951: movl $orvl$,r6 # load return by value word
13952: #
13953: # MERGE HERE TO CONSTRUCT EXBLK
13954: #
13955: cdgx3: jsb cdwrd # generate return word
13956: jsb exbld # build exblk
13957: movl (sp)+,r8 # restore wc
13958: rsb # return to cdgex caller
13959: #enp # end procedure cdgex
13960: #page
13961: #
13962: # CDGNM -- GENERATE CODE BY NAME
13963: #
13964: # CDGNM IS CALLED DURING THE COMPILATION PROCESS TO
13965: # GENERATE CODE BY NAME FOR AN EXPRESSION. SEE CDBLK
13966: # DESCRIPTION FOR DETAILS OF CODE GENERATED. THE INPUT
13967: # TO CDGNM IS AN EXPRESSION TREE AS GENERATED BY EXPAN.
13968: #
13969: # CDGNM IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING
13970: # RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS.
13971: #
13972: # (WB) INTEGER IN RANGE 0 LE N LE DNAMB
13973: # (XR) PTR TO TREE GENERATED BY EXPAN
13974: # (WC) CONSTANT FLAG (SEE BELOW)
13975: # JSR CDGNM CALL TO GENERATE CODE BY NAME
13976: # (XR,WA) DESTROYED
13977: # (WC) SET NON-ZERO IF NON-CONSTANT
13978: #
13979: # WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE
13980: # EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE
13981: # EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED.
13982: #
13983: # THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD).
13984: #
13985: cdgnm: #prc # entry point, recursive
13986: movl r10,-(sp) # save entry xl
13987: movl r7,-(sp) # save entry wb
13988: jsb sbchk # check for stack overflow
13989: movl (r9),r6 # load type word
13990: cmpl r6,$b$cmt # jump if cmblk
13991: beqlu cgn04
13992: cmpl r6,$b$vr$ # jump if simple variable
13993: blssu 0f
13994: jmp cgn02
13995: 0:
13996: #
13997: # MERGE HERE FOR OPERAND YIELDING VALUE (E.G. CONSTANT)
13998: #
13999: cgn01: jmp er_212 # syntax error. value used where name is required
14000: #
14001: # HERE FOR NATURAL VARIABLE REFERENCE
14002: #
14003: cgn02: movl $olvn$,r6 # load variable load call
14004: jsb cdwrd # generate it
14005: movl r9,r6 # copy vrblk pointer
14006: jsb cdwrd # generate vrblk pointer
14007: #page
14008: #
14009: # CDGNM (CONTINUED)
14010: #
14011: # HERE TO EXIT WITH WC SET CORRECTLY
14012: #
14013: cgn03: movl (sp)+,r7 # restore entry wb
14014: movl (sp)+,r10 # restore entry xl
14015: rsb # return to cdgnm caller
14016: #
14017: # HERE FOR CMBLK
14018: #
14019: cgn04: movl r9,r10 # copy cmblk pointer
14020: movl 4*cmtyp(r9),r9 # load cmblk type
14021: cmpl r9,$c$$nm # error if not name operand
14022: bgequ cgn01
14023: casel r9,$0,$c$$nm # else switch on type
14024: 5:
14025: .word cgn05-5b # array reference
14026: .word cgn08-5b # function call
14027: .word cgn09-5b # deferred expression
14028: .word cgn10-5b # indirect reference
14029: .word cgn11-5b # keyword reference
14030: .word cgn08-5b # undefined binary op
14031: .word cgn08-5b # undefined unary op
14032: #esw # end switch on cmblk type
14033: #
14034: # HERE TO GENERATE CODE FOR ARRAY REFERENCE
14035: #
14036: cgn05: movl $4*cmopn,r7 # point to array operand
14037: #
14038: # LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
14039: #
14040: cgn06: jsb cmgen # generate code for next operand
14041: movl 4*cmlen(r10),r8 # load length of cmblk
14042: cmpl r7,r8 # loop till all generated
14043: blssu cgn06
14044: #
14045: # GENERATE APPROPRIATE ARRAY CALL
14046: #
14047: movl $oaon$,r6 # load one-subscript case call
14048: cmpl r8,$4*cmar1 # jump to exit if one subscript case
14049: beqlu cgn07
14050: movl $oamn$,r6 # else load multi-subscript case call
14051: jsb cdwrd # generate call
14052: movl r8,r6 # copy cmblk length
14053: ashl $-2,r6,r6 # convert to words
14054: subl2 $cmvls,r6 # calculate number of subscripts
14055: #page
14056: #
14057: # CDGNM (CONTINUED)
14058: #
14059: # HERE TO EXIT GENERATING WORD (NON-CONSTANT)
14060: #
14061: cgn07: movl sp,r8 # set result non-constant
14062: jsb cdwrd # generate word
14063: jmp cgn03 # back to exit
14064: #
14065: # HERE TO GENERATE CODE FOR FUNCTIONS AND UNDEFINED OPRS
14066: #
14067: cgn08: movl r10,r9 # copy cmblk pointer
14068: jsb cdgvl # gen code by value for call
14069: movl $ofne$,r6 # get extra call for by name
14070: jmp cgn07 # back to generate and exit
14071: #
14072: # HERE TO GENERATE CODE FOR DEFERED EXPRESSION
14073: #
14074: cgn09: movl 4*cmrop(r10),r9 # check if variable
14075: cmpl (r9),$b$vr$ # treat *variable as simple var
14076: blssu 0f
14077: jmp cgn02
14078: 0:
14079: movl r9,r10 # copy ptr to expression tree
14080: jsb cdgex # else build exblk
14081: movl $olex$,r6 # set call to load expr by name
14082: jsb cdwrd # generate it
14083: movl r9,r6 # copy exblk pointer
14084: jsb cdwrd # generate exblk pointer
14085: jmp cgn03 # back to exit
14086: #
14087: # HERE TO GENERATE CODE FOR INDIRECT REFERENCE
14088: #
14089: cgn10: movl 4*cmrop(r10),r9 # get operand
14090: jsb cdgvl # generate code by value for it
14091: movl $oinn$,r6 # load call for indirect by name
14092: jmp cgn12 # merge
14093: #
14094: # HERE TO GENERATE CODE FOR KEYWORD REFERENCE
14095: #
14096: cgn11: movl 4*cmrop(r10),r9 # get operand
14097: jsb cdgnm # generate code by name for it
14098: movl $okwn$,r6 # load call for keyword by name
14099: #
14100: # KEYWORD, INDIRECT MERGE HERE
14101: #
14102: cgn12: jsb cdwrd # generate code for operator
14103: jmp cgn03 # exit
14104: #enp # end procedure cdgnm
14105: #page
14106: #
14107: # CDGVL -- GENERATE CODE BY VALUE
14108: #
14109: # CDGVL IS CALLED DURING THE COMPILATION PROCESS TO
14110: # GENERATE CODE BY VALUE FOR AN EXPRESSION. SEE CDBLK
14111: # DESCRIPTION FOR DETAILS OF THE CODE GENERATED. THE INPUT
14112: # TO CDGVL IS AN EXPRESSION TREE AS GENERATED BY EXPAN.
14113: #
14114: # CDGVL IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING
14115: # RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS.
14116: #
14117: # (WB) INTEGER IN RANGE 0 LE N LE DNAMB
14118: # (XR) PTR TO TREE GENERATED BY EXPAN
14119: # (WC) CONSTANT FLAG (SEE BELOW)
14120: # JSR CDGVL CALL TO GENERATE CODE BY VALUE
14121: # (XR,WA) DESTROYED
14122: # (WC) SET NON-ZERO IF NON-CONSTANT
14123: #
14124: # WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE
14125: # EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE
14126: # EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED.
14127: #
14128: # IF WC IS NON-ZERO ON ENTRY, THEN PREEVALUATION IS NOT
14129: # ALLOWED REGARDLESS OF THE NATURE OF THE OPERAND.
14130: #
14131: # THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD).
14132: #
14133: cdgvl: #prc # entry point, recursive
14134: movl (r9),r6 # load type word
14135: cmpl r6,$b$cmt # jump if cmblk
14136: beqlu cgv01
14137: cmpl r6,$b$vra # jump if icblk, rcblk, scblk
14138: blssu cgv00
14139: tstl 4*vrlen(r9) # jump if not system variable
14140: bnequ cgvl0
14141: movl r9,-(sp) # stack xr
14142: movl 4*vrsvp(r9),r9 # point to svblk
14143: movl 4*svbit(r9),r6 # get svblk property bits
14144: movl (sp)+,r9 # recover xr
14145: mcoml btckw,r11 # check if constant keyword
14146: bicl2 r11,r6
14147: bnequ cgv00 # jump if constant keyword
14148: #
14149: # HERE FOR VARIABLE VALUE REFERENCE
14150: #
14151: cgvl0: movl sp,r8 # indicate non-constant value
14152: #
14153: # MERGE HERE FOR SIMPLE CONSTANT (ICBLK,RCBLK,SCBLK)
14154: # AND FOR VARIABLES CORRESPONDING TO CONSTANT KEYWORDS.
14155: #
14156: cgv00: movl r9,r6 # copy ptr to var or constant
14157: jsb cdwrd # generate as code word
14158: rsb # return to caller
14159: #page
14160: #
14161: # CDGVL (CONTINUED)
14162: #
14163: # HERE FOR TREE NODE (CMBLK)
14164: #
14165: cgv01: movl r7,-(sp) # save entry wb
14166: movl r10,-(sp) # save entry xl
14167: movl r8,-(sp) # save entry constant flag
14168: movl cwcof,-(sp) # save initial code offset
14169: jsb sbchk # check for stack overflow
14170: #
14171: # PREPARE TO GENERATE CODE FOR CMBLK. WC IS SET TO THE
14172: # VALUE OF CSWNO (ZERO IF -OPTIMISE, 1 IF -NOOPT) TO
14173: # START WITH AND IS RESET NON-ZERO FOR ANY NON-CONSTANT
14174: # CODE GENERATED. IF IT IS STILL ZERO AFTER GENERATING ALL
14175: # THE CMBLK CODE, THEN ITS VALUE IS COMPUTED AS THE RESULT.
14176: #
14177: movl r9,r10 # copy cmblk pointer
14178: movl 4*cmtyp(r9),r9 # load cmblk type
14179: movl cswno,r8 # reset constant flag
14180: cmpl r9,$c$pr$ # jump if not predicate value
14181: blequ cgv02
14182: movl sp,r8 # else force non-constant case
14183: #
14184: # HERE WITH WC SET APPROPRIATELY
14185: #
14186: cgv02: casel r9,$0,$c$$nv # switch to appropriate generator
14187: 5:
14188: .word cgv03-5b # array reference
14189: .word cgv05-5b # function call
14190: .word cgv14-5b # deferred expression
14191: .word cgv31-5b # indirect reference
14192: .word cgv27-5b # keyword reference
14193: .word cgv29-5b # undefined binop
14194: .word cgv30-5b # undefined unop
14195: .word cgv18-5b # binops with val opds
14196: .word cgv19-5b # unops with valu opnd
14197: .word cgv18-5b # alternation
14198: .word cgv24-5b # concatenation
14199: .word cgv24-5b # concatenation (not pattern match)
14200: .word cgv27-5b # unops with name opnd
14201: .word cgv26-5b # binary $ and .
14202: .word cgv21-5b # assignment
14203: .word cgv31-5b # interrogation
14204: .word cgv28-5b # negation
14205: .word cgv15-5b # selection
14206: .word cgv18-5b # pattern match
14207: #esw # end switch on cmblk type
14208: #page
14209: #
14210: # CDGVL (CONTINUED)
14211: #
14212: # HERE TO GENERATE CODE FOR ARRAY REFERENCE
14213: #
14214: cgv03: movl $4*cmopn,r7 # set offset to array operand
14215: #
14216: # LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
14217: #
14218: cgv04: jsb cmgen # gen value code for next operand
14219: movl 4*cmlen(r10),r8 # load cmblk length
14220: cmpl r7,r8 # loop back if more to go
14221: blssu cgv04
14222: #
14223: # GENERATE CALL TO APPROPRIATE ARRAY REFERENCE ROUTINE
14224: #
14225: movl $oaov$,r6 # set one subscript call in case
14226: cmpl r8,$4*cmar1 # jump to exit if 1-sub case
14227: bnequ 0f
14228: jmp cgv32
14229: 0:
14230: movl $oamv$,r6 # else set call for multi-subscripts
14231: jsb cdwrd # generate call
14232: movl r8,r6 # copy length of cmblk
14233: subl2 $4*cmvls,r6 # subtract standard length
14234: ashl $-2,r6,r6 # get number of words
14235: jmp cgv32 # jump to generate subscript count
14236: #
14237: # HERE TO GENERATE CODE FOR FUNCTION CALL
14238: #
14239: cgv05: movl $4*cmvls,r7 # set offset to first argument
14240: #
14241: # LOOP TO GENERATE CODE FOR ARGUMENTS
14242: #
14243: cgv06: cmpl r7,4*cmlen(r10) # jump if all generated
14244: beqlu cgv07
14245: jsb cmgen # else gen value code for next arg
14246: jmp cgv06 # back to generate next argument
14247: #
14248: # HERE TO GENERATE ACTUAL FUNCTION CALL
14249: #
14250: cgv07: subl2 $4*cmvls,r7 # get number of arg ptrs (bytes)
14251: ashl $-2,r7,r7 # convert bytes to words
14252: movl 4*cmopn(r10),r9 # load function vrblk pointer
14253: tstl 4*vrlen(r9) # jump if not system function
14254: bnequ cgv12
14255: movl 4*vrsvp(r9),r10 # load svblk ptr if system var
14256: movl 4*svbit(r10),r6 # load bit mask
14257: mcoml btffc,r11 # test for fast function call allowed
14258: bicl2 r11,r6
14259: beqlu cgv12 # jump if not
14260: #page
14261: #
14262: # CDGVL (CONTINUED)
14263: #
14264: # HERE IF FAST FUNCTION CALL IS ALLOWED
14265: #
14266: movl 4*svbit(r10),r6 # reload bit indicators
14267: mcoml btpre,r11 # test for preevaluation ok
14268: bicl2 r11,r6
14269: bnequ cgv08 # jump if preevaluation permitted
14270: movl sp,r8 # else set result non-constant
14271: #
14272: # TEST FOR CORRECT NUMBER OF ARGS FOR FAST CALL
14273: #
14274: cgv08: movl 4*vrfnc(r9),r10 # load ptr to svfnc field
14275: movl 4*fargs(r10),r6 # load svnar field value
14276: cmpl r6,r7 # jump if argument count is correct
14277: beqlu cgv11
14278: cmpl r6,r7 # jump if too few arguments given
14279: bgequ cgv09
14280: #
14281: # HERE IF TOO MANY ARGUMENTS, PREPARE TO GENERATE O$POPS
14282: #
14283: subl2 r6,r7 # get number of extra args
14284: # set as count to control loop
14285: movl $opop$,r6 # set pop call
14286: jmp cgv10 # jump to common loop
14287: #
14288: # HERE IF TOO FEW ARGUMENTS, PREPARE TO GENERATE NULLS
14289: #
14290: cgv09: subl2 r7,r6 # get number of missing arguments
14291: movl r6,r7 # load as count to control loop
14292: movl $nulls,r6 # load ptr to null constant
14293: #
14294: # LOOP TO GENERATE CALLS TO FIX ARGUMENT COUNT
14295: #
14296: cgv10: jsb cdwrd # generate one call
14297: sobgtr r7,cgv10 # loop till all generated
14298: #
14299: # HERE AFTER ADJUSTING ARG COUNT AS REQUIRED
14300: #
14301: cgv11: movl r10,r6 # copy pointer to svfnc field
14302: jmp cgv36 # jump to generate call
14303: #page
14304: #
14305: # CDGVL (CONTINUED)
14306: #
14307: # COME HERE IF FAST CALL IS NOT PERMITTED
14308: #
14309: cgv12: movl $ofns$,r6 # set one arg call in case
14310: cmpl r7,$num01 # jump if one arg case
14311: beqlu cgv13
14312: movl $ofnc$,r6 # else load call for more than 1 arg
14313: jsb cdwrd # generate it
14314: movl r7,r6 # copy argument count
14315: #
14316: # ONE ARG CASE MERGES HERE
14317: #
14318: cgv13: jsb cdwrd # generate =o$fns or arg count
14319: movl r9,r6 # copy vrblk pointer
14320: jmp cgv32 # jump to generate vrblk ptr
14321: #
14322: # HERE FOR DEFERRED EXPRESSION
14323: #
14324: cgv14: movl 4*cmrop(r10),r10# point to expression tree
14325: jsb cdgex # build exblk or seblk
14326: movl r9,r6 # copy block ptr
14327: jsb cdwrd # generate ptr to exblk or seblk
14328: jmp cgv34 # jump to exit, constant test
14329: #
14330: # HERE TO GENERATE CODE FOR SELECTION
14331: #
14332: cgv15: clrl -(sp) # zero ptr to chain of forward jumps
14333: clrl -(sp) # zero ptr to prev o$slc forward ptr
14334: movl $4*cmvls,r7 # point to first alternative
14335: movl $osla$,r6 # set initial code word
14336: #
14337: # 0(XS) IS THE OFFSET TO THE PREVIOUS WORD
14338: # WHICH REQUIRES FILLING IN WITH AN
14339: # OFFSET TO THE FOLLOWING O$SLC,O$SLD
14340: #
14341: # 1(XS) IS THE HEAD OF A CHAIN OF OFFSET
14342: # POINTERS INDICATING THOSE LOCATIONS
14343: # TO BE FILLED WITH OFFSETS PAST
14344: # THE END OF ALL THE ALTERNATIVES
14345: #
14346: cgv16: jsb cdwrd # generate o$slc (o$sla first time)
14347: movl cwcof,(sp) # set current loc as ptr to fill in
14348: jsb cdwrd # generate garbage word there for now
14349: jsb cmgen # gen value code for alternative
14350: movl $oslb$,r6 # load o$slb pointer
14351: jsb cdwrd # generate o$slb call
14352: movl 4*1(sp),r6 # load old chain ptr
14353: movl cwcof,4*1(sp) # set current loc as new chain head
14354: jsb cdwrd # generate forward chain link
14355: #page
14356: #
14357: # CDGVL (CONTINUED)
14358: #
14359: # NOW TO FILL IN THE SKIP OFFSET TO O$SLC,O$SLD
14360: #
14361: movl (sp),r9 # load offset to word to plug
14362: addl2 r$ccb,r9 # point to actual location to plug
14363: movl cwcof,(r9) # plug proper offset in
14364: movl $oslc$,r6 # load o$slc ptr for next alternative
14365: movl r7,r9 # copy offset (destroy garbage xr)
14366: addl2 $4,r9 # bump extra time for test
14367: cmpl r9,4*cmlen(r10) # loop back if not last alternative
14368: blssu cgv16
14369: #
14370: # HERE TO GENERATE CODE FOR LAST ALTERNATIVE
14371: #
14372: movl $osld$,r6 # get header call
14373: jsb cdwrd # generate o$sld call
14374: jsb cmgen # generate code for last alternative
14375: addl2 $4,sp # pop offset ptr
14376: movl (sp)+,r9 # load chain ptr
14377: #
14378: # LOOP TO PLUG OFFSETS PAST STRUCTURE
14379: #
14380: cgv17: addl2 r$ccb,r9 # make next ptr absolute
14381: movl (r9),r6 # load forward ptr
14382: movl cwcof,(r9) # plug required offset
14383: movl r6,r9 # copy forward ptr
14384: tstl r6 # loop back if more to go
14385: bnequ cgv17
14386: jmp cgv33 # else jump to exit (not constant)
14387: #
14388: # HERE FOR BINARY OPS WITH VALUE OPERANDS
14389: #
14390: cgv18: movl 4*cmlop(r10),r9 # load left operand pointer
14391: jsb cdgvl # gen value code for left operand
14392: #
14393: # HERE FOR UNARY OPS WITH VALUE OPERAND (BINOPS MERGE)
14394: #
14395: cgv19: movl 4*cmrop(r10),r9 # load right (only) operand ptr
14396: jsb cdgvl # gen code by value
14397: #page
14398: #
14399: # CDGVL (CONTINUED)
14400: #
14401: # MERGE HERE TO GENERATE OPERATOR CALL FROM CMOPN FIELD
14402: #
14403: cgv20: movl 4*cmopn(r10),r6 # load operator call pointer
14404: jmp cgv36 # jump to generate it with cons test
14405: #
14406: # HERE FOR ASSIGNMENT
14407: #
14408: cgv21: movl 4*cmlop(r10),r9 # load left operand pointer
14409: cmpl (r9),$b$vr$ # jump if not variable
14410: blequ cgv22
14411: #
14412: # HERE FOR ASSIGNMENT TO SIMPLE VARIABLE
14413: #
14414: movl 4*cmrop(r10),r9 # load right operand ptr
14415: jsb cdgvl # generate code by value
14416: movl 4*cmlop(r10),r6 # reload left operand vrblk ptr
14417: addl2 $4*vrsto,r6 # point to vrsto field
14418: jmp cgv32 # jump to generate store ptr
14419: #
14420: # HERE IF NOT SIMPLE VARIABLE ASSIGNMENT
14421: #
14422: cgv22: jsb expap # test for pattern match on left side
14423: .long cgv23 # jump if not pattern match
14424: #
14425: # HERE FOR PATTERN REPLACEMENT
14426: #
14427: movl 4*cmrop(r9),4*cmlop(r10) # save pattern ptr in safe place
14428: movl 4*cmlop(r9),r9 # load subject ptr
14429: jsb cdgnm # gen code by name for subject
14430: movl 4*cmlop(r10),r9 # load pattern ptr
14431: jsb cdgvl # gen code by value for pattern
14432: movl $opmn$,r6 # load match by name call
14433: jsb cdwrd # generate it
14434: movl 4*cmrop(r10),r9 # load replacement value ptr
14435: jsb cdgvl # gen code by value
14436: movl $orpl$,r6 # load replace call
14437: jmp cgv32 # jump to gen and exit (not constant)
14438: #
14439: # HERE FOR ASSIGNMENT TO COMPLEX VARIABLE
14440: #
14441: cgv23: movl sp,r8 # inhibit pre-evaluation
14442: jsb cdgnm # gen code by name for left side
14443: jmp cgv31 # merge with unop circuit
14444: #page
14445: #
14446: # CDGVL (CONTINUED)
14447: #
14448: # HERE FOR CONCATENATION
14449: #
14450: cgv24: movl 4*cmlop(r10),r9 # load left operand ptr
14451: cmpl (r9),$b$cmt # ordinary binop if not cmblk
14452: beqlu 0f
14453: jmp cgv18
14454: 0:
14455: movl 4*cmtyp(r9),r7 # load cmblk type code
14456: cmpl r7,$c$int # special case if interrogation
14457: beqlu cgv25
14458: cmpl r7,$c$neg # or negation
14459: beqlu cgv25
14460: cmpl r7,$c$fnc # else ordinary binop if not function
14461: beqlu 0f
14462: jmp cgv18
14463: 0:
14464: movl 4*cmopn(r9),r9 # else load function vrblk ptr
14465: tstl 4*vrlen(r9) # ordinary binop if not system var
14466: beqlu 0f
14467: jmp cgv18
14468: 0:
14469: movl 4*vrsvp(r9),r9 # else point to svblk
14470: movl 4*svbit(r9),r6 # load bit indicators
14471: mcoml btprd,r11 # test for predicate function
14472: bicl2 r11,r6
14473: bnequ 0f # ordinary binop if not
14474: jmp cgv18
14475: 0:
14476: #
14477: # HERE IF LEFT ARG OF CONCATENATION IS PREDICATE FUNCTION
14478: #
14479: cgv25: movl 4*cmlop(r10),r9 # reload left arg
14480: jsb cdgvl # gen code by value
14481: movl $opop$,r6 # load pop call
14482: jsb cdwrd # generate it
14483: movl 4*cmrop(r10),r9 # load right operand
14484: jsb cdgvl # gen code by value as result code
14485: jmp cgv33 # exit (not constant)
14486: #
14487: # HERE TO GENERATE CODE FOR PATTERN, IMMEDIATE ASSIGNMENT
14488: #
14489: cgv26: movl 4*cmlop(r10),r9 # load left operand
14490: jsb cdgvl # gen code by value, merge
14491: #
14492: # HERE FOR UNOPS WITH ARG BY NAME (BINARY $ . MERGE)
14493: #
14494: cgv27: movl 4*cmrop(r10),r9 # load right operand ptr
14495: jsb cdgnm # gen code by name for right arg
14496: movl 4*cmopn(r10),r9 # get operator code word
14497: cmpl (r9),$o$kwv # gen call unless keyword value
14498: beqlu 0f
14499: jmp cgv20
14500: 0:
14501: #page
14502: #
14503: # CDGVL (CONTINUED)
14504: #
14505: # HERE FOR KEYWORD BY VALUE. THIS IS CONSTANT ONLY IF
14506: # THE OPERAND IS ONE OF THE SPECIAL SYSTEM VARIABLES WITH
14507: # THE SVCKW BIT SET TO INDICATE A CONSTANT KEYWORD VALUE.
14508: # NOTE THAT THE ONLY CONSTANT OPERAND BY NAME IS A VARIABLE
14509: #
14510: tstl r8 # gen call if non-constant (not var)
14511: beqlu 0f
14512: jmp cgv20
14513: 0:
14514: movl sp,r8 # else set non-constant in case
14515: movl 4*cmrop(r10),r9 # load ptr to operand vrblk
14516: tstl 4*vrlen(r9) # gen (non-constant) if not sys var
14517: beqlu 0f
14518: jmp cgv20
14519: 0:
14520: movl 4*vrsvp(r9),r9 # else load ptr to svblk
14521: movl 4*svbit(r9),r6 # load bit mask
14522: mcoml btckw,r11 # test for constant keyword
14523: bicl2 r11,r6
14524: bnequ 0f # go gen if not constant
14525: jmp cgv20
14526: 0:
14527: clrl r8 # else set result constant
14528: jmp cgv20 # and jump back to generate call
14529: #
14530: # HERE TO GENERATE CODE FOR NEGATION
14531: #
14532: cgv28: movl $onta$,r6 # get initial word
14533: jsb cdwrd # generate it
14534: movl cwcof,r7 # save next offset
14535: jsb cdwrd # generate gunk word for now
14536: movl 4*cmrop(r10),r9 # load right operand ptr
14537: jsb cdgvl # gen code by value
14538: movl $ontb$,r6 # load end of evaluation call
14539: jsb cdwrd # generate it
14540: movl r7,r9 # copy offset to word to plug
14541: addl2 r$ccb,r9 # point to actual word to plug
14542: movl cwcof,(r9) # plug word with current offset
14543: movl $ontc$,r6 # load final call
14544: jmp cgv32 # jump to generate it (not constant)
14545: #
14546: # HERE TO GENERATE CODE FOR UNDEFINED BINARY OPERATOR
14547: #
14548: cgv29: movl 4*cmlop(r10),r9 # load left operand ptr
14549: jsb cdgvl # generate code by value
14550: #page
14551: #
14552: # CDGVL (CONTINUED)
14553: #
14554: # HERE TO GENERATE CODE FOR UNDEFINED UNARY OPERATOR
14555: #
14556: cgv30: movl $c$uo$,r7 # set unop code + 1
14557: subl2 4*cmtyp(r10),r7 # set number of args (1 or 2)
14558: #
14559: # MERGE HERE FOR UNDEFINED OPERATORS
14560: #
14561: movl 4*cmrop(r10),r9 # load right (only) operand pointer
14562: jsb cdgvl # gen value code for right operand
14563: movl 4*cmopn(r10),r9 # load pointer to operator dv
14564: movl 4*dvopn(r9),r9 # load pointer offset
14565: moval 0[r9],r9 # convert word offset to bytes
14566: addl2 $r$uba,r9 # point to proper function ptr
14567: subl2 $4*vrfnc,r9 # set standard function offset
14568: jmp cgv12 # merge with function call circuit
14569: #
14570: # HERE TO GENERATE CODE FOR INTERROGATION, INDIRECTION
14571: #
14572: cgv31: movl sp,r8 # set non constant
14573: jmp cgv19 # merge
14574: #
14575: # HERE TO EXIT GENERATING A WORD, RESULT NOT CONSTANT
14576: #
14577: cgv32: jsb cdwrd # generate word, merge
14578: #
14579: # HERE TO EXIT WITH NO WORD GENERATED, NOT CONSTANT
14580: #
14581: cgv33: movl sp,r8 # indicate result is not constant
14582: #
14583: # COMMON EXIT POINT
14584: #
14585: cgv34: addl2 $4,sp # pop initial code offset
14586: movl (sp)+,r6 # restore old constant flag
14587: movl (sp)+,r10 # restore entry xl
14588: movl (sp)+,r7 # restore entry wb
14589: tstl r8 # jump if not constant
14590: bnequ cgv35
14591: movl r6,r8 # else restore entry constant flag
14592: #
14593: # HERE TO RETURN AFTER DEALING WITH WC SETTING
14594: #
14595: cgv35: rsb # return to cdgvl caller
14596: #
14597: # EXIT HERE TO GENERATE WORD AND TEST FOR CONSTANT
14598: #
14599: cgv36: jsb cdwrd # generate word
14600: tstl r8 # jump to exit if not constant
14601: bnequ cgv34
14602: #page
14603: #
14604: # CDGVL (CONTINUED)
14605: #
14606: # HERE TO PREEVALUATE CONSTANT SUB-EXPRESSION
14607: #
14608: movl $orvl$,r6 # load call to return value
14609: jsb cdwrd # generate it
14610: movl (sp),r10 # load initial code offset
14611: jsb exbld # build exblk for expression
14612: clrl r7 # set to evaluate by value
14613: jsb evalx # evaluate expression
14614: .long invalid$ # should not fail
14615: movl (r9),r6 # load type word of result
14616: cmpl r6,$p$aaa # jump if not pattern
14617: blequ cgv37
14618: movl $olpt$,r6 # else load special pattern load call
14619: jsb cdwrd # generate it
14620: #
14621: # MERGE HERE TO GENERATE POINTER TO RESULTING CONSTANT
14622: #
14623: cgv37: movl r9,r6 # copy constant pointer
14624: jsb cdwrd # generate ptr
14625: clrl r8 # set result constant
14626: jmp cgv34 # jump back to exit
14627: #enp # end procedure cdgvl
14628: #page
14629: #
14630: # CDWRD -- GENERATE ONE WORD OF CODE
14631: #
14632: # CDWRD WRITES ONE WORD INTO THE CURRENT CODE BLOCK UNDER
14633: # CONSTRUCTION. A NEW, LARGER, BLOCK IS ALLOCATED IF THERE
14634: # IS INSUFFICIENT ROOM IN THE CURRENT BLOCK. CDWRD ENSURES
14635: # THAT THERE ARE AT LEAST THREE WORDS LEFT IN THE BLOCK
14636: # AFTER ENTERING THE NEW WORD. THIS GUARANTEES THAT ANY
14637: # EXTRA SPACE AT THE END CAN BE SPLIT OFF AS A CCBLK.
14638: #
14639: # (WA) WORD TO BE GENERATED
14640: # JSR CDWRD CALL TO GENERATE WORD
14641: #
14642: cdwrd: #prc # entry point
14643: movl r9,-(sp) # save entry xr
14644: movl r6,-(sp) # save code word to be generated
14645: #
14646: # MERGE BACK HERE AFTER ALLOCATING LARGER BLOCK
14647: #
14648: cdwd1: movl r$ccb,r9 # load ptr to ccblk being built
14649: bnequ cdwd2 # jump if block allocated
14650: #
14651: # HERE WE ALLOCATE AN ENTIRELY FRESH BLOCK
14652: #
14653: movl $4*e$cbs,r6 # load initial length
14654: jsb alloc # allocate ccblk
14655: movl $b$cct,(r9) # store type word
14656: movl $4*cccod,cwcof # set initial offset
14657: movl r6,4*cclen(r9) # store block length
14658: movl r9,r$ccb # store ptr to new block
14659: #
14660: # HERE WE HAVE A BLOCK WE CAN USE
14661: #
14662: cdwd2: movl cwcof,r6 # load current offset
14663: addl2 $4*num04,r6 # adjust for test (four words)
14664: cmpl r6,4*cclen(r9) # jump if room in this block
14665: bgtru 0f
14666: jmp cdwd4
14667: 0:
14668: #
14669: # HERE IF NO ROOM IN CURRENT BLOCK
14670: #
14671: cmpl r6,mxlen # jump if already at max size
14672: blssu 0f
14673: jmp cdwd5
14674: 0:
14675: addl2 $4*e$cbs,r6 # else get new size
14676: movl r10,-(sp) # save entry xl
14677: movl r9,r10 # copy pointer
14678: cmpl r6,mxlen # jump if not too large
14679: blssu cdwd3
14680: movl mxlen,r6 # else reset to max allowed size
14681: #page
14682: #
14683: # CDWRD (CONTINUED)
14684: #
14685: # HERE WITH NEW BLOCK SIZE IN WA
14686: #
14687: cdwd3: jsb alloc # allocate new block
14688: movl r9,r$ccb # store pointer to new block
14689: movl $b$cct,(r9)+ # store type word in new block
14690: movl r6,(r9)+ # store block length
14691: addl2 $4*ccuse,r10 # point to ccuse,cccod fields in old
14692: movl (r10),r6 # load ccuse value
14693: jsb sbmvw # copy useful words from old block
14694: movl (sp)+,r10 # restore xl
14695: jmp cdwd1 # merge back to try again
14696: #
14697: # HERE WITH ROOM IN CURRENT BLOCK
14698: #
14699: cdwd4: movl cwcof,r6 # load current offset
14700: addl2 $4,r6 # get new offset
14701: movl r6,cwcof # store new offset
14702: movl r6,4*ccuse(r9) # store in ccblk for gbcol
14703: subl2 $4,r6 # restore ptr to this word
14704: addl2 r6,r9 # point to current entry
14705: movl (sp)+,r6 # reload word to generate
14706: movl r6,(r9) # store word in block
14707: movl (sp)+,r9 # restore entry xr
14708: rsb # return to caller
14709: #
14710: # HERE IF COMPILED CODE IS TOO LONG FOR CDBLK
14711: #
14712: cdwd5: jmp er_213 # syntax error. statement is too complicated.
14713: #enp # end procedure cdwrd
14714: #page
14715: #
14716: # CMGEN -- GENERATE CODE FOR CMBLK PTR
14717: #
14718: # CMGEN IS A SUBSIDIARY PROCEDURE USED TO GENERATE VALUE
14719: # CODE FOR A CMBLK PTR FROM THE MAIN CODE GENERATORS.
14720: #
14721: # (XL) CMBLK POINTER
14722: # (WB) OFFSET TO POINTER IN CMBLK
14723: # JSR CMGEN CALL TO GENERATE CODE
14724: # (XR,WA) DESTROYED
14725: # (WB) BUMPED BY ONE WORD
14726: #
14727: cmgen: #prc # entry point, recursive
14728: movl r10,r9 # copy cmblk pointer
14729: addl2 r7,r9 # point to cmblk pointer
14730: movl (r9),r9 # load cmblk pointer
14731: jsb cdgvl # generate code by value
14732: addl2 $4,r7 # bump offset
14733: rsb # return to caller
14734: #enp # end procedure cmgen
14735: #page
14736: #
14737: # CMPIL (COMPILE SOURCE CODE)
14738: #
14739: # CMPIL IS USED TO CONVERT SNOBOL4 SOURCE CODE TO INTERNAL
14740: # FORM (SEE CDBLK FORMAT). IT IS USED BOTH FOR THE INITIAL
14741: # COMPILE AND AT RUN TIME BY THE CODE AND CONVERT FUNCTIONS
14742: # THIS PROCEDURE HAS CONTROL FOR THE ENTIRE DURATION OF
14743: # INITIAL COMPILATION. AN ERROR IN ANY PROCEDURE CALLED
14744: # DURING COMPILATION WILL LEAD FIRST TO THE ERROR SECTION
14745: # AND ULTIMATELY BACK HERE FOR RESUMED COMPILATION. THE
14746: # RE-ENTRY POINTS AFTER AN ERROR ARE SPECIALLY LABELLED -
14747: #
14748: # CMPCE RESUME AFTER CONTROL CARD ERROR
14749: # CMPLE RESUME AFTER LABEL ERROR
14750: # CMPSE RESUME AFTER STATEMENT ERROR
14751: #
14752: # JSR CMPIL CALL TO COMPILE CODE
14753: # (XR) PTR TO CDBLK FOR ENTRY STATEMENT
14754: # (XL,WA,WB,WC,RA) DESTROYED
14755: #
14756: # THE FOLLOWING GLOBAL VARIABLES ARE REFERENCED
14757: #
14758: # CMPSN NUMBER OF NEXT STATEMENT
14759: # TO BE COMPILED.
14760: #
14761: # CSWXX CONTROL CARD SWITCH VALUES ARE
14762: # CHANGED WHEN RELEVANT CONTROL
14763: # CARDS ARE MET.
14764: #
14765: # CWCOF OFFSET TO NEXT WORD IN CODE BLOCK
14766: # BEING BUILT (SEE CDWRD).
14767: #
14768: # LSTSN NUMBER OF STATEMENT MOST RECENTLY
14769: # COMPILED (INITIALLY SET TO ZERO).
14770: #
14771: # R$CIM CURRENT (INITIAL) COMPILER IMAGE
14772: # (ZERO FOR INITIAL COMPILE CALL)
14773: #
14774: # R$CNI USED TO POINT TO FOLLOWING IMAGE.
14775: # (SEE READR PROCEDURE).
14776: #
14777: # SCNGO GOTO SWITCH FOR SCANE PROCEDURE
14778: #
14779: # SCNIL LENGTH OF CURRENT IMAGE EXCLUDING
14780: # CHARACTERS REMOVED BY -INPUT.
14781: #
14782: # SCNPT CURRENT SCAN OFFSET, SEE SCANE.
14783: #
14784: # SCNRS RESCAN SWITCH FOR SCANE PROCEDURE.
14785: #
14786: # SCNSE OFFSET (IN R$CIM) OF MOST RECENTLY
14787: # SCANNED ELEMENT. SET ZERO IF NOT
14788: # CURRENTLY SCANNING ITEMS
14789: #page
14790: #
14791: # CMPIL (CONTINUED)
14792: #
14793: # STAGE STGIC INITIAL COMPILE IN PROGRESS
14794: # STGXC CODE/CONVERT COMPILE
14795: # STGEV BUILDING EXBLK FOR EVAL
14796: # STGXT EXECUTE TIME (OUTSIDE COMPILE)
14797: # STGCE INITIAL COMPILE AFTER END LINE
14798: # STGXE EXECUTE COMPILE AFTER END LINE
14799: #
14800: # CMPIL ALSO USES A FIXED NUMBER OF LOCATIONS ON THE
14801: # MAIN STACK AS FOLLOWS. (THE DEFINITIONS OF THE ACTUAL
14802: # OFFSETS ARE IN THE DEFINITIONS SECTION).
14803: #
14804: # CMSTM(XS) POINTER TO EXPAN TREE FOR BODY OF
14805: # STATEMENT (SEE EXPAN PROCEDURE).
14806: #
14807: # CMSGO(XS) POINTER TO TREE REPRESENTATION OF
14808: # SUCCESS GOTO (SEE PROCEDURE SCNGO)9
14809: # ZERO IF NO SUCCESS GOTO IS GIVEN
14810: #
14811: # CMFGO(XS) LIKE CMSGO FOR FAILURE GOTO.
14812: #
14813: # CMCGO(XS) SET NON-ZERO ONLY IF THERE IS A
14814: # CONDITIONAL GOTO. USED FOR -FAIL,
14815: # -NOFAIL CODE GENERATION.
14816: #
14817: # CMPCD(XS) POINTER TO CDBLK FOR PREVIOUS
14818: # STATEMENT. ZERO FOR 1ST STATEMENT.
14819: #
14820: # CMFFP(XS) SET NON-ZERO IF CDFAL IN PREVIOUS
14821: # CDBLK NEEDS FILLING WITH FORWARD
14822: # POINTER, ELSE SET TO ZERO.
14823: #
14824: # CMFFC(XS) SAME AS CMFFP FOR CURRENT CDBLK
14825: #
14826: # CMSOP(XS) OFFSET TO WORD IN PREVIOUS CDBLK
14827: # TO BE FILLED IN WITH FORWARD PTR
14828: # TO NEXT CDBLK FOR SUCCESS GOTO.
14829: # ZERO IF NO FILL IN IS REQUIRED.
14830: #
14831: # CMSOC(XS) SAME AS CMSOP FOR CURRENT CDBLK.
14832: #
14833: # CMLBL(XS) POINTER TO VRBLK FOR LABEL OF
14834: # CURRENT STATEMENT. ZERO IF NO LABEL
14835: #
14836: # CMTRA(XS) POINTER TO CDBLK FOR ENTRY STMNT.
14837: #page
14838: #
14839: # CMPIL (CONTINUED)
14840: #
14841: # ENTRY POINT
14842: #
14843: cmpil: #prc # entry point
14844: movl $cmnen,r7 # set number of stack work locations
14845: #
14846: # LOOP TO INITIALIZE STACK WORKING LOCATIONS
14847: #
14848: cmp00: clrl -(sp) # store a zero, make one entry
14849: sobgtr r7,cmp00 # loop back until all set
14850: movl sp,cmpxs # save stack pointer for error sec
14851: #sss cmpss # save s-r stack pointer if any
14852: #
14853: # LOOP THROUGH STATEMENTS
14854: #
14855: cmp01: movl scnpt,r7 # set scan pointer offset
14856: movl r7,scnse # set start of element location
14857: movl $ocer$,r6 # point to compile error call
14858: jsb cdwrd # generate as temporary cdfal
14859: cmpl r7,scnil # jump if chars left on this image
14860: blssu cmp04
14861: #
14862: # LOOP HERE AFTER COMMENT OR CONTROL CARD
14863: # ALSO SPECIAL ENTRY AFTER CONTROL CARD ERROR
14864: #
14865: cmpce: clrl r9 # clear possible garbage xr value
14866: cmpl stage,$stgic # skip unless initial compile
14867: bnequ cmp02
14868: jsb readr # read next input image
14869: tstl r9 # jump if no input available
14870: bnequ 0f
14871: jmp cmp09
14872: 0:
14873: jsb nexts # acquire next source image
14874: movl cmpsn,lstsn # store stmt no for use by listr
14875: clrl scnpt # reset scan pointer
14876: jmp cmp04 # go process image
14877: #
14878: # FOR EXECUTE TIME COMPILE, PERMIT EMBEDDED CONTROL CARDS
14879: # AND COMMENTS (BY SKIPPING TO NEXT SEMI-COLON)
14880: #
14881: cmp02: movl r$cim,r9 # get current image
14882: movl scnpt,r7 # get current offset
14883: movab cfp$f(r9)[r7],r9# prepare to get chars
14884: #
14885: # SKIP TO SEMI-COLON
14886: #
14887: cmp03: movzbl (r9)+,r8 # get char
14888: incl scnpt # advance offset
14889: cmpl r8,$ch$sm # skip if semi-colon found
14890: beqlu cmp04
14891: cmpl scnpt,scnil # loop if more chars
14892: blssu cmp03
14893: clrl r9 # clear garbage xr value
14894: jmp cmp09 # end of image
14895: #page
14896: #
14897: # CMPIL (CONTINUED)
14898: #
14899: # HERE WITH IMAGE AVAILABLE TO SCAN. NOTE THAT IF THE INPUT
14900: # STRING IS NULL, THEN EVERYTHING IS OK SINCE NULL IS
14901: # ACTUALLY ASSEMBLED AS A WORD OF BLANKS.
14902: #
14903: cmp04: movl r$cim,r9 # point to current image
14904: movl scnpt,r7 # load current offset
14905: movl r7,r6 # copy for label scan
14906: movab cfp$f(r9)[r7],r9# point to first character
14907: movzbl (r9)+,r8 # load first character
14908: cmpl r8,$ch$sm # no label if semicolon
14909: bnequ 0f
14910: jmp cmp12
14911: 0:
14912: cmpl r8,$ch$as # loop back if comment card
14913: bnequ 0f
14914: jmp cmpce
14915: 0:
14916: cmpl r8,$ch$mn # jump if control card
14917: bnequ 0f
14918: jmp cmp32
14919: 0:
14920: movl r$cim,r$cmp # about to destroy r$cim
14921: movl $cmlab,r10 # point to label work string
14922: movl r10,r$cim # scane is to scan work string
14923: movab cfp$f(r10),r10 # point to first character position
14924: movb r8,(r10)+ # store char just loaded
14925: movl $ch$sm,r8 # get a semicolon
14926: movb r8,(r10) # store after first char
14927: #csc r10 # finished character storing
14928: clrl r10 # clear pointer
14929: clrl scnpt # start at first character
14930: movl scnil,-(sp) # preserve image length
14931: movl $num02,scnil # read 2 chars at most
14932: jsb scane # scan first char for type
14933: movl (sp)+,scnil # restore image length
14934: movl r10,r8 # note return code
14935: movl r$cmp,r10 # get old r$cim
14936: movl r10,r$cim # put it back
14937: movl r7,scnpt # reinstate offset
14938: tstl scnbl # blank seen - cant be label
14939: beqlu 0f
14940: jmp cmp12
14941: 0:
14942: movl r10,r9 # point to current image
14943: movab cfp$f(r9)[r7],r9# point to first char again
14944: cmpl r8,$t$var # ok if letter
14945: beqlu cmp06
14946: cmpl r8,$t$con # ok if digit
14947: beqlu cmp06
14948: #
14949: # DROP IN OR JUMP FROM ERROR SECTION IF SCANE FAILED
14950: #
14951: cmple: movl r$cmp,r$cim # point to bad line
14952: jmp er_214 # bad label or misplaced continuation line
14953: #
14954: # LOOP TO SCAN LABEL
14955: #
14956: cmp05: cmpl r8,$ch$sm # skip if semicolon
14957: beqlu cmp07
14958: incl r6 # bump offset
14959: cmpl r6,scnil # jump if end of image (label end)
14960: beqlu cmp07
14961: #page
14962: #
14963: # CMPIL (CONTINUED)
14964: #
14965: # ENTER LOOP AT THIS POINT
14966: #
14967: cmp06: movzbl (r9)+,r8 # else load next character
14968: cmpl r8,$ch$ht # jump if horizontal tab
14969: beqlu cmp07
14970: cmpl r8,$ch$bl # loop back if non-blank
14971: bnequ cmp05
14972: #
14973: # HERE AFTER SCANNING OUT LABEL
14974: #
14975: cmp07: movl r6,scnpt # save updated scan offset
14976: subl2 r7,r6 # get length of label
14977: bnequ 0f # skip if label length zero
14978: jmp cmp12
14979: 0:
14980: clrl r9 # clear garbage xr value
14981: jsb sbstr # build scblk for label name
14982: jsb gtnvr # locate/contruct vrblk
14983: .long invalid$ # dummy (impossible) error return
14984: movl r9,4*cmlbl(sp) # store label pointer
14985: tstl 4*vrlen(r9) # jump if not system label
14986: bnequ cmp11
14987: cmpl 4*vrsvp(r9),$v$end # jump if not end label
14988: bnequ cmp11
14989: #
14990: # HERE FOR END LABEL SCANNED OUT
14991: #
14992: addl2 $stgnd,stage # adjust stage appropriately
14993: jsb scane # scan out next element
14994: cmpl r10,$t$smc # jump if end of image
14995: bnequ 0f
14996: jmp cmp10
14997: 0:
14998: cmpl r10,$t$var # else error if not variable
14999: bnequ cmp08
15000: #
15001: # HERE CHECK FOR VALID INITIAL TRANSFER
15002: #
15003: cmpl 4*vrlbl(r9),$stndl # jump if not defined (error)
15004: beqlu cmp08
15005: movl 4*vrlbl(r9),4*cmtra(sp) # else set initial entry pointer
15006: jsb scane # scan next element
15007: cmpl r10,$t$smc # jump if ok (end of image)
15008: bnequ 0f
15009: jmp cmp10
15010: 0:
15011: #
15012: # HERE FOR BAD TRANSFER LABEL
15013: #
15014: cmp08: jmp er_215 # syntax error. undefined or erroneous entry label
15015: #
15016: # HERE FOR END OF INPUT (NO END LABEL DETECTED)
15017: #
15018: cmp09: addl2 $stgnd,stage # adjust stage appropriately
15019: cmpl stage,$stgxe # jump if code call (ok)
15020: bnequ 0f
15021: jmp cmp10
15022: 0:
15023: jmp er_216 # syntax error. missing end line
15024: #
15025: # HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR)
15026: #
15027: cmp10: movl $ostp$,r6 # set stop call pointer
15028: jsb cdwrd # generate as statement call
15029: jmp cmpse # jump to generate as failure
15030: #page
15031: #
15032: # CMPIL (CONTINUED)
15033: #
15034: # HERE AFTER PROCESSING LABEL OTHER THAN END
15035: #
15036: cmp11: cmpl stage,$stgic # jump if code call - redef. ok
15037: beqlu 0f
15038: jmp cmp12
15039: 0:
15040: cmpl 4*vrlbl(r9),$stndl # else check for redefinition
15041: bnequ 0f
15042: jmp cmp12
15043: 0:
15044: clrl 4*cmlbl(sp) # leave first label decln undisturbed
15045: jmp er_217 # syntax error. duplicate label
15046: #
15047: # HERE AFTER DEALING WITH LABEL
15048: #
15049: cmp12: clrl r7 # set flag for statement body
15050: jsb expan # get tree for statement body
15051: movl r9,4*cmstm(sp) # store for later use
15052: clrl 4*cmsgo(sp) # clear success goto pointer
15053: clrl 4*cmfgo(sp) # clear failure goto pointer
15054: clrl 4*cmcgo(sp) # clear conditional goto flag
15055: jsb scane # scan next element
15056: cmpl r10,$t$col # jump it not colon (no goto)
15057: beqlu 0f
15058: jmp cmp18
15059: 0:
15060: #
15061: # LOOP TO PROCESS GOTO FIELDS
15062: #
15063: cmp13: movl sp,scngo # set goto flag
15064: jsb scane # scan next element
15065: cmpl r10,$t$smc # jump if no fields left
15066: bnequ 0f
15067: jmp cmp31
15068: 0:
15069: cmpl r10,$t$sgo # jump if s for success goto
15070: beqlu cmp14
15071: cmpl r10,$t$fgo # jump if f for failure goto
15072: beqlu cmp16
15073: #
15074: # HERE FOR UNCONDITIONAL GOTO (I.E. NOT F OR S)
15075: #
15076: movl sp,scnrs # set to rescan element not f,s
15077: jsb scngf # scan out goto field
15078: tstl 4*cmfgo(sp) # error if fgoto already
15079: bnequ cmp17
15080: movl r9,4*cmfgo(sp) # else set as fgoto
15081: jmp cmp15 # merge with sgoto circuit
15082: #
15083: # HERE FOR SUCCESS GOTO
15084: #
15085: cmp14: jsb scngf # scan success goto field
15086: movl $num01,4*cmcgo(sp) # set conditional goto flag
15087: #
15088: # UNCONTIONAL GOTO MERGES HERE
15089: #
15090: cmp15: tstl 4*cmsgo(sp) # error if sgoto already given
15091: bnequ cmp17
15092: movl r9,4*cmsgo(sp) # else set sgoto
15093: jmp cmp13 # loop back for next goto field
15094: #
15095: # HERE FOR FAILURE GOTO
15096: #
15097: cmp16: jsb scngf # scan goto field
15098: movl $num01,4*cmcgo(sp) # set conditonal goto flag
15099: tstl 4*cmfgo(sp) # error if fgoto already given
15100: bnequ cmp17
15101: movl r9,4*cmfgo(sp) # else store fgoto pointer
15102: jmp cmp13 # loop back for next field
15103: #page
15104: #
15105: # CMPIL (CONTINUED)
15106: #
15107: # HERE FOR DUPLICATED GOTO FIELD
15108: #
15109: cmp17: jmp er_218 # syntax error. duplicated goto field
15110: #
15111: # HERE TO GENERATE CODE
15112: #
15113: cmp18: clrl scnse # stop positional error flags
15114: movl 4*cmstm(sp),r9 # load tree ptr for statement body
15115: clrl r7 # collectable value for wb for cdgvl
15116: clrl r8 # reset constant flag for cdgvl
15117: jsb expap # test for pattern match
15118: .long cmp19 # jump if not pattern match
15119: movl $opms$,4*cmopn(r9) # else set pattern match pointer
15120: movl $c$pmt,4*cmtyp(r9)
15121: #
15122: # HERE AFTER DEALING WITH SPECIAL PATTERN MATCH CASE
15123: #
15124: cmp19: jsb cdgvl # generate code for body of statement
15125: movl 4*cmsgo(sp),r9 # load sgoto pointer
15126: movl r9,r6 # copy it
15127: tstl r9 # jump if no success goto
15128: beqlu cmp21
15129: clrl 4*cmsoc(sp) # clear success offset fillin ptr
15130: cmpl r9,state # jump if complex goto
15131: bgequ cmp20
15132: #
15133: # HERE FOR SIMPLE SUCCESS GOTO (LABEL)
15134: #
15135: addl2 $4*vrtra,r6 # point to vrtra field as required
15136: jsb cdwrd # generate success goto
15137: jmp cmp22 # jump to deal with fgoto
15138: #
15139: # HERE FOR COMPLEX SUCCESS GOTO
15140: #
15141: cmp20: cmpl r9,4*cmfgo(sp) # no code if same as fgoto
15142: beqlu cmp22
15143: clrl r7 # else set ok value for cdgvl in wb
15144: jsb cdgcg # generate code for success goto
15145: jmp cmp22 # jump to deal with fgoto
15146: #
15147: # HERE FOR NO SUCCESS GOTO
15148: #
15149: cmp21: movl cwcof,4*cmsoc(sp)# set success fill in offset
15150: movl $ocer$,r6 # point to compile error call
15151: jsb cdwrd # generate as temporary value
15152: #page
15153: #
15154: # CMPIL (CONTINUED)
15155: #
15156: # HERE TO DEAL WITH FAILURE GOTO
15157: #
15158: cmp22: movl 4*cmfgo(sp),r9 # load failure goto pointer
15159: movl r9,r6 # copy it
15160: clrl 4*cmffc(sp) # set no fill in required yet
15161: tstl r9 # jump if no failure goto given
15162: beqlu cmp23
15163: addl2 $4*vrtra,r6 # point to vrtra field in case
15164: cmpl r9,state # jump to gen if simple fgoto
15165: blequ cmpse
15166: #
15167: # HERE FOR COMPLEX FAILURE GOTO
15168: #
15169: movl cwcof,r7 # save offset to o$gof call
15170: movl $ogof$,r6 # point to failure goto call
15171: jsb cdwrd # generate
15172: movl $ofif$,r6 # point to fail in fail word
15173: jsb cdwrd # generate
15174: jsb cdgcg # generate code for failure goto
15175: movl r7,r6 # copy offset to o$gof for cdfal
15176: movl $b$cdc,r7 # set complex case cdtyp
15177: jmp cmp25 # jump to build cdblk
15178: #
15179: # HERE IF NO FAILURE GOTO GIVEN
15180: #
15181: cmp23: movl $ounf$,r6 # load unexpected failure call in cas
15182: movl cswfl,r8 # get -nofail flag
15183: bisl2 4*cmcgo(sp),r8 # check if conditional goto
15184: beqlu cmpse # jump if -nofail and no cond. goto
15185: movl sp,4*cmffc(sp) # else set fill in flag
15186: movl $ocer$,r6 # and set compile error for temporary
15187: #
15188: # MERGE HERE WITH CDFAL VALUE IN WA, SIMPLE CDBLK
15189: # ALSO SPECIAL ENTRY AFTER STATEMENT ERROR
15190: #
15191: cmpse: movl $b$cds,r7 # set cdtyp for simple case
15192: #page
15193: #
15194: # CMPIL (CONTINUED)
15195: #
15196: # MERGE HERE TO BUILD CDBLK
15197: #
15198: # (WA) CDFAL VALUE TO BE GENERATED
15199: # (WB) CDTYP VALUE TO BE GENERATED
15200: #
15201: # AT THIS STAGE, WE CHOP OFF AN APPROPRIATE CHUNK OF THE
15202: # CURRENT CCBLK AND CONVERT IT INTO A CDBLK. THE REMAINDER
15203: # OF THE CCBLK IS REFORMATTED TO BE THE NEW CCBLK.
15204: #
15205: cmp25: movl r$ccb,r9 # point to ccblk
15206: movl 4*cmlbl(sp),r10 # get possible label pointer
15207: beqlu cmp26 # skip if no label
15208: clrl 4*cmlbl(sp) # clear flag for next statement
15209: movl r9,4*vrlbl(r10) # put cdblk ptr in vrblk label field
15210: #
15211: # MERGE AFTER DOING LABEL
15212: #
15213: cmp26: movl r7,(r9) # set type word for new cdblk
15214: movl r6,4*cdfal(r9) # set failure word
15215: movl r9,r10 # copy pointer to ccblk
15216: movl 4*ccuse(r9),r7 # load length gen (= new cdlen)
15217: movl 4*cclen(r9),r8 # load total ccblk length
15218: addl2 r7,r10 # point past cdblk
15219: subl2 r7,r8 # get length left for chop off
15220: movl $b$cct,(r10) # set type code for new ccblk at end
15221: movl $4*cccod,4*ccuse(r10) # set initial code offset
15222: movl $4*cccod,cwcof # reinitialise cwcof
15223: movl r8,4*cclen(r10) # set new length
15224: movl r10,r$ccb # set new ccblk pointer
15225: movl cmpsn,4*cdstm(r9)# set statement number
15226: incl cmpsn # bump statement number
15227: #
15228: # SET POINTERS IN PREVIOUS CODE BLOCK AS REQUIRED
15229: #
15230: movl 4*cmpcd(sp),r10 # load ptr to previous cdblk
15231: tstl 4*cmffp(sp) # jump if no failure fill in required
15232: beqlu cmp27
15233: movl r9,4*cdfal(r10) # else set failure ptr in previous
15234: #
15235: # HERE TO DEAL WITH SUCCESS FORWARD POINTER
15236: #
15237: cmp27: movl 4*cmsop(sp),r6 # load success offset
15238: beqlu cmp28 # jump if no fill in required
15239: addl2 r6,r10 # else point to fill in location
15240: movl r9,(r10) # store forward pointer
15241: clrl r10 # clear garbage xl value
15242: #page
15243: #
15244: # CMPIL (CONTINUED)
15245: #
15246: # NOW SET FILL IN POINTERS FOR THIS STATEMENT
15247: #
15248: cmp28: movl 4*cmffc(sp),4*cmffp(sp) # copy failure fill in flag
15249: movl 4*cmsoc(sp),4*cmsop(sp) # copy success fill in offset
15250: movl r9,4*cmpcd(sp) # save ptr to this cdblk
15251: tstl 4*cmtra(sp) # jump if initial entry already set
15252: bnequ cmp29
15253: movl r9,4*cmtra(sp) # else set ptr here as default
15254: #
15255: # HERE AFTER COMPILING ONE STATEMENT
15256: #
15257: cmp29: cmpl stage,$stgce # jump if not end line just done
15258: bgequ 0f
15259: jmp cmp01
15260: 0:
15261: tstl cswls # skip if -nolist
15262: beqlu cmp30
15263: jsb listr # list last line
15264: #
15265: # RETURN
15266: #
15267: cmp30: movl 4*cmtra(sp),r9 # load initial entry cdblk pointer
15268: addl2 $4*cmnen,sp # pop work locations off stack
15269: rsb # and return to cmpil caller
15270: #
15271: # HERE AT END OF GOTO FIELD
15272: #
15273: cmp31: movl 4*cmfgo(sp),r7 # get fail goto
15274: bisl2 4*cmsgo(sp),r7 # or in success goto
15275: beqlu 0f # ok if non-null field
15276: jmp cmp18
15277: 0:
15278: jmp er_219 # syntax error. empty goto field
15279: #
15280: # CONTROL CARD FOUND
15281: #
15282: cmp32: incl r7 # point past ch$mn
15283: jsb cncrd # process control card
15284: clrl scnse # clear start of element loc.
15285: jmp cmpce # loop for next statement
15286: #enp # end procedure cmpil
15287: #page
15288: #
15289: # CNCRD -- CONTROL CARD PROCESSOR
15290: #
15291: # CALLED TO DEAL WITH CONTROL CARDS
15292: #
15293: # R$CIM POINTS TO CURRENT IMAGE
15294: # (WB) OFFSET TO 1ST CHAR OF CONTROL CARD
15295: # JSR CNCRD CALL TO PROCESS CONTROL CARDS
15296: # (XL,XR,WA,WB,WC,IA) DESTROYED
15297: #
15298: cncrd: #prc # entry point
15299: movl r7,scnpt # offset for control card scan
15300: movl $ccnoc,r6 # number of chars for comparison
15301: movab 3+(4*0)(r6),r6 # convert to word count
15302: ashl $-2,r6,r6
15303: movl r6,cnswc # save word count
15304: #
15305: # LOOP HERE IF MORE THAN ONE CONTROL CARD
15306: #
15307: cnc01: cmpl scnpt,scnil # return if end of image
15308: blssu 0f
15309: jmp cnc09
15310: 0:
15311: movl r$cim,r9 # point to image
15312: movl scnpt,r11 # [get in scratch register]
15313: movab cfp$f(r9)[r11],r9# char ptr for first char
15314: movzbl (r9)+,r6 # get first char
15315: bicl2 $ch$bl,r6 # fold to upper case
15316: cmpl r6,$ch$li # special case of -inxxx
15317: bnequ 0f
15318: jmp cnc07
15319: 0:
15320: movl sp,scncc # set flag for scane
15321: jsb scane # scan card name
15322: clrl scncc # clear scane flag
15323: tstl r10 # fail unless control card name
15324: beqlu 0f
15325: jmp cnc06
15326: 0:
15327: movl $ccnoc,r6 # no. of chars to be compared
15328: cmpl 4*sclen(r9),r6 # fail if too few chars
15329: bgequ 0f
15330: jmp cnc06
15331: 0:
15332: movl r9,r10 # point to control card name
15333: clrl r7 # zero offset for substring
15334: jsb sbstr # extract substring for comparison
15335: movl 4*sclen(r9),r6 # reload length
15336: jsb flstg # fold to upper case
15337: movl r9,cnscc # keep control card substring ptr
15338: movl $ccnms,r9 # point to list of standard names
15339: clrl r7 # initialise name offset
15340: movl $cc$nc,r8 # number of standard names
15341: #
15342: # TRY TO MATCH NAME
15343: #
15344: cnc02: movl cnscc,r10 # point to name
15345: movl cnswc,r6 # counter for inner loop
15346: jmp cnc04 # jump into loop
15347: #
15348: # INNER LOOP TO MATCH CARD NAME CHARS
15349: #
15350: cnc03: addl2 $4,r9 # bump standard names ptr
15351: addl2 $4,r10 # bump name pointer
15352: #
15353: # HERE TO INITIATE THE LOOP
15354: #
15355: cnc04: cmpl 4*schar(r10),(r9)# comp. up to cfp$c chars at once
15356: bnequ cnc05
15357: sobgtr r6,cnc03 # loop if more words to compare
15358: #page
15359: #
15360: # CNCRD (CONTINUED)
15361: #
15362: # MATCHED - BRANCH ON CARD OFFSET
15363: #
15364: movl r7,r10 # get name offset
15365: casel r10,$0,$cc$nc # switch
15366: 5:
15367: .word cnc37-5b # -case
15368: .word cnc10-5b # -double
15369: .word cnc11-5b # -dump
15370: .word cnc12-5b # -eject
15371: .word cnc13-5b # -errors
15372: .word cnc14-5b # -execute
15373: .word cnc15-5b # -fail
15374: .word cnc16-5b # -list
15375: .word cnc17-5b # -noerrors
15376: .word cnc18-5b # -noexecute
15377: .word cnc19-5b # -nofail
15378: .word cnc20-5b # -nolist
15379: .word cnc21-5b # -noopt
15380: .word cnc22-5b # -noprint
15381: .word cnc24-5b # -optimise
15382: .word cnc25-5b # -print
15383: .word cnc27-5b # -single
15384: .word cnc28-5b # -space
15385: .word cnc31-5b # -stitle
15386: .word cnc32-5b # -title
15387: .word cnc36-5b # -trace
15388: #esw # end switch
15389: #
15390: # NOT MATCHED YET. ALIGN STD NAMES PTR AND TRY AGAIN
15391: #
15392: cnc05: addl2 $4,r9 # bump standard names ptr
15393: sobgtr r6,cnc05 # loop
15394: incl r7 # bump names offset
15395: sobgtr r8,cnc02 # continue if more names
15396: #
15397: # INVALID CONTROL CARD NAME
15398: #
15399: cnc06: jmp er_247 # invalid control card
15400: #
15401: # SPECIAL PROCESSING FOR -INXXX
15402: #
15403: cnc07: movzbl (r9),r6 # get next char
15404: bicl2 $ch$bl,r6 # fold to upper case
15405: cmpl r6,$ch$ln # fail if not letter n
15406: beqlu 0f
15407: jmp cnc06
15408: 0:
15409: addl2 $num02,scnpt # bump offset past -in
15410: jsb scane # scan integer after -in
15411: movl r9,-(sp) # stack scanned item
15412: jsb gtsmi # check if integer
15413: .long cnc06 # fail if not integer
15414: .long cnc06 # fail if negative or large
15415: movl r9,cswin # keep integer
15416: #page
15417: #
15418: # CNCRD (CONTINUED)
15419: #
15420: # CHECK FOR MORE CONTROL CARDS BEFORE RETURNING
15421: #
15422: cnc08: movl scnpt,r6 # preserve in case xeq time compile
15423: jsb scane # look for comma
15424: cmpl r10,$t$cma # loop if comma found
15425: bnequ 0f
15426: jmp cnc01
15427: 0:
15428: movl r6,scnpt # restore scnpt in case xeq time
15429: #
15430: # RETURN POINT
15431: #
15432: cnc09: rsb # return
15433: #
15434: # -DOUBLE
15435: #
15436: cnc10: movl sp,cswdb # set switch
15437: jmp cnc08 # merge
15438: #
15439: # -DUMP
15440: # THIS IS USED FOR SYSTEM DEBUGGING . IT HAS THE EFFECT OF
15441: # PRODUCING A CORE DUMP AT COMPILATION TIME
15442: #
15443: cnc11: jsb sysdm # call dumper
15444: jmp cnc09 # finished
15445: #
15446: # -EJECT
15447: #
15448: cnc12: tstl cswls # return if -nolist
15449: bnequ 0f
15450: jmp cnc09
15451: 0:
15452: jsb prtps # eject
15453: jsb listt # list title
15454: jmp cnc09 # finished
15455: #
15456: # -ERRORS
15457: #
15458: cnc13: clrl cswer # clear switch
15459: jmp cnc08 # merge
15460: #
15461: # -EXECUTE
15462: #
15463: cnc14: clrl cswex # clear switch
15464: jmp cnc08 # merge
15465: #
15466: # -FAIL
15467: #
15468: cnc15: movl sp,cswfl # set switch
15469: jmp cnc08 # merge
15470: #
15471: # -LIST
15472: #
15473: cnc16: movl sp,cswls # set switch
15474: cmpl stage,$stgic # done if compile time
15475: beqlu cnc08
15476: #
15477: # LIST CODE LINE IF EXECUTE TIME COMPILE
15478: #
15479: clrl lstpf # permit listing
15480: jsb listr # list line
15481: jmp cnc08 # merge
15482: #page
15483: #
15484: # CNCRD (CONTINUED)
15485: #
15486: # -NOERRORS
15487: #
15488: cnc17: movl sp,cswer # set switch
15489: jmp cnc08 # merge
15490: #
15491: # -NOEXECUTE
15492: #
15493: cnc18: movl sp,cswex # set switch
15494: jmp cnc08 # merge
15495: #
15496: # -NOFAIL
15497: #
15498: cnc19: clrl cswfl # clear switch
15499: jmp cnc08 # merge
15500: #
15501: # -NOLIST
15502: #
15503: cnc20: clrl cswls # clear switch
15504: jmp cnc08 # merge
15505: #
15506: # -NOOPTIMISE
15507: #
15508: cnc21: movl sp,cswno # set switch
15509: jmp cnc08 # merge
15510: #
15511: # -NOPRINT
15512: #
15513: cnc22: clrl cswpr # clear switch
15514: jmp cnc08 # merge
15515: #
15516: # -OPTIMISE
15517: #
15518: cnc24: clrl cswno # clear switch
15519: jmp cnc08 # merge
15520: #
15521: # -PRINT
15522: #
15523: cnc25: movl sp,cswpr # set switch
15524: jmp cnc08 # merge
15525: #page
15526: #
15527: # CNCRD (CONTINUED)
15528: #
15529: # -SINGLE
15530: #
15531: cnc27: clrl cswdb # clear switch
15532: jmp cnc08 # merge
15533: #
15534: # -SPACE
15535: #
15536: cnc28: tstl cswls # return if -nolist
15537: bnequ 0f
15538: jmp cnc09
15539: 0:
15540: jsb scane # scan integer after -space
15541: movl $num01,r8 # 1 space in case
15542: cmpl r9,$t$smc # jump if no integer
15543: beqlu cnc29
15544: movl r9,-(sp) # stack it
15545: jsb gtsmi # check integer
15546: .long cnc06 # fail if not integer
15547: .long cnc06 # fail if negative or large
15548: tstl r8 # jump if non zero
15549: bnequ cnc29
15550: movl $num01,r8 # else 1 space
15551: #
15552: # MERGE WITH COUNT OF LINES TO SKIP
15553: #
15554: cnc29: addl2 r8,lstlc # bump line count
15555: # convert to loop counter
15556: cmpl lstlc,lstnp # jump if fits on page
15557: blssu cnc30
15558: jsb prtps # eject
15559: jsb listt # list title
15560: jmp cnc09 # merge
15561: #
15562: # SKIP LINES
15563: #
15564: cnc30: jsb prtnl # print a blank
15565: sobgtr r8,cnc30 # loop
15566: jmp cnc09 # merge
15567: #page
15568: #
15569: # CNCRD (CONTINUED)
15570: #
15571: # -STITL
15572: #
15573: cnc31: movl $r$stl,cnr$t # ptr to r$stl
15574: jmp cnc33 # merge
15575: #
15576: # -TITLE
15577: #
15578: cnc32: movl $nulls,r$stl # clear subtitle
15579: movl $r$ttl,cnr$t # ptr to r$ttl
15580: #
15581: # COMMON PROCESSING FOR -TITLE, -STITL
15582: #
15583: cnc33: movl $nulls,r9 # null in case needed
15584: movl sp,cnttl # set flag for next listr call
15585: movl $ccofs,r7 # offset to title/subtitle
15586: movl scnil,r6 # input image length
15587: cmpl r6,r7 # jump if no chars left
15588: blequ cnc34
15589: subl2 r7,r6 # no of chars to extract
15590: movl r$cim,r10 # point to image
15591: jsb sbstr # get title/subtitle
15592: #
15593: # STORE TITLE/SUBTITLE
15594: #
15595: cnc34: movl cnr$t,r10 # point to storage location
15596: movl r9,(r10) # store title/subtitle
15597: cmpl r10,$r$stl # return if stitl
15598: bnequ 0f
15599: jmp cnc09
15600: 0:
15601: tstl precl # return if extended listing
15602: beqlu 0f
15603: jmp cnc09
15604: 0:
15605: tstl prich # return if regular printer
15606: bnequ 0f
15607: jmp cnc09
15608: 0:
15609: movl 4*sclen(r9),r10 # get length of title
15610: movl r10,r6 # copy it
15611: tstl r10 # jump if null
15612: beqlu cnc35
15613: addl2 $num10,r10 # increment
15614: cmpl r10,prlen # use default lstp0 val if too long
15615: blssu 0f
15616: jmp cnc09
15617: 0:
15618: addl2 $num04,r6 # point just past title
15619: #
15620: # STORE OFFSET TO PAGE NN MESSAGE FOR SHORT TITLE
15621: #
15622: cnc35: movl r6,lstpo # store offset
15623: jmp cnc09 # return
15624: #
15625: # -TRACE
15626: # PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL
15627: # TRACE SWITCH AT COMPILE TIME
15628: #
15629: cnc36: jsb systt # toggle switch
15630: jmp cnc08 # merge
15631: #
15632: # -CASE
15633: # SETS VALUE OF KVCAS SO THAT NAMES ARE FOLDED OR NOT
15634: # DURING COMPILATION.
15635: #
15636: cnc37: jsb scane # scan integer after -case
15637: clrl r8 # get 0 in case none there
15638: cmpl r10,$t$smc # skip if no integer
15639: beqlu cnc38
15640: movl r9,-(sp) # stack it
15641: jsb gtsmi # check integer
15642: .long cnc06 # fail if not integer
15643: .long cnc06 # fail if negative or too large
15644: cnc38: movl r8,kvcas # store new case value
15645: jmp cnc09 # merge
15646: #enp # end procedure cncrd
15647: #page
15648: #
15649: # DFFNC -- DEFINE FUNCTION
15650: #
15651: # DFFNC IS CALLED WHENEVER A NEW FUNCTION IS ASSIGNED TO
15652: # A VARIABLE. IT DEALS WITH EXTERNAL FUNCTION USE COUNTS.
15653: #
15654: # (XR) POINTER TO VRBLK
15655: # (XL) POINTER TO NEW FUNCTION BLOCK
15656: # JSR DFFNC CALL TO DEFINE FUNCTION
15657: # (WA,WB) DESTROYED
15658: #
15659: dffnc: #prc # entry point
15660: cmpl (r10),$b$efc # skip if new function not external
15661: bnequ dffn1
15662: incl 4*efuse(r10) # else increment its use count
15663: #
15664: # HERE AFTER DEALING WITH NEW FUNCTION USE COUNT
15665: #
15666: dffn1: movl r9,r6 # save vrblk pointer
15667: movl 4*vrfnc(r9),r9 # load old function pointer
15668: cmpl (r9),$b$efc # jump if old function not external
15669: bnequ dffn2
15670: movl 4*efuse(r9),r7 # else get use count
15671: decl r7 # decrement
15672: movl r7,4*efuse(r9) # store decremented value
15673: tstl r7 # jump if use count still non-zero
15674: bnequ dffn2
15675: jsb sysul # else call system unload function
15676: #
15677: # HERE AFTER DEALING WITH OLD FUNCTION USE COUNT
15678: #
15679: dffn2: movl r6,r9 # restore vrblk pointer
15680: movl r10,r6 # copy function block ptr
15681: cmpl r9,$r$yyy # skip checks if opsyn op definition
15682: blssu dffn3
15683: tstl 4*vrlen(r9) # jump if not system variable
15684: bnequ dffn3
15685: #
15686: # FOR SYSTEM VARIABLE, CHECK FOR ILLEGAL REDEFINITION
15687: #
15688: movl 4*vrsvp(r9),r10 # point to svblk
15689: movl 4*svbit(r10),r7 # load bit indicators
15690: mcoml btfnc,r11 # is it a system function
15691: bicl2 r11,r7
15692: beqlu dffn3 # redef ok if not
15693: jmp er_248 # attempted redefinition of system function
15694: #
15695: # HERE IF REDEFINITION IS PERMITTED
15696: #
15697: dffn3: movl r6,4*vrfnc(r9) # store new function pointer
15698: movl r6,r10 # restore function block pointer
15699: rsb # return to dffnc caller
15700: #enp # end procedure dffnc
15701: #page
15702: #
15703: # DTACH -- DETACH I/O ASSOCIATED NAMES
15704: #
15705: # DETACHES TRBLKS FROM I/O ASSOCIATED VARIABLES, REMOVES
15706: # ENTRY FROM IOCHN CHAIN ATTACHED TO FILEARG1 VRBLK AND MAY
15707: # REMOVE VRBLK ACCESS AND STORE TRAPS.
15708: # INPUT, OUTPUT, TERMINAL ARE HANDLED SPECIALLY.
15709: #
15710: # (XL) I/O ASSOC. VBL NAME BASE PTR
15711: # (WA) OFFSET TO NAME
15712: # JSR DTACH CALL FOR DETACH OPERATION
15713: # (XL,XR,WA,WB,WC) DESTROYED
15714: #
15715: dtach: #prc # entry point
15716: movl r10,dtcnb # store name base (gbcol not called)
15717: addl2 r6,r10 # point to name location
15718: movl r10,dtcnm # store it
15719: #
15720: # LOOP TO SEARCH FOR I/O TRBLK
15721: #
15722: dtch1: movl r10,r9 # copy name pointer
15723: #
15724: # CONTINUE AFTER BLOCK DELETION
15725: #
15726: dtch2: movl (r10),r10 # point to next value
15727: cmpl (r10),$b$trt # jump at chain end
15728: bnequ dtch6
15729: movl 4*trtyp(r10),r6 # get trap block type
15730: cmpl r6,$trtin # jump if input
15731: beqlu dtch3
15732: cmpl r6,$trtou # jump if output
15733: beqlu dtch3
15734: addl2 $4*trnxt,r10 # point to next link
15735: jmp dtch1 # loop
15736: #
15737: # DELETE AN OLD ASSOCIATION
15738: #
15739: dtch3: movl 4*trval(r10),(r9)# delete trblk
15740: movl r10,r6 # dump xl ...
15741: movl r9,r7 # ... and xr
15742: movl 4*trtrf(r10),r10# point to trtrf trap block
15743: beqlu dtch5 # jump if no iochn
15744: cmpl (r10),$b$trt # jump if input, output, terminal
15745: bnequ dtch5
15746: #
15747: # LOOP TO SEARCH IOCHN CHAIN FOR NAME PTR
15748: #
15749: dtch4: movl r10,r9 # remember link ptr
15750: movl 4*trtrf(r10),r10# point to next link
15751: beqlu dtch5 # jump if end of chain
15752: movl 4*ionmb(r10),r8 # get name base
15753: addl2 4*ionmo(r10),r8 # add offset
15754: cmpl r8,dtcnm # loop if no match
15755: bnequ dtch4
15756: movl 4*trtrf(r10),4*trtrf(r9) # remove name from chain
15757: #page
15758: #
15759: # DTACH (CONTINUED)
15760: #
15761: # PREPARE TO RESUME I/O TRBLK SCAN
15762: #
15763: dtch5: movl r6,r10 # recover xl ...
15764: movl r7,r9 # ... and xr
15765: addl2 $4*trval,r10 # point to value field
15766: jmp dtch2 # continue
15767: #
15768: # EXIT POINT
15769: #
15770: dtch6: movl dtcnb,r9 # possible vrblk ptr
15771: jsb setvr # reset vrblk if necessary
15772: rsb # return
15773: #enp # end procedure dtach
15774: #page
15775: #
15776: # DTYPE -- GET DATATYPE NAME
15777: #
15778: # (XR) OBJECT WHOSE DATATYPE IS REQUIRED
15779: # JSR DTYPE CALL TO GET DATATYPE
15780: # (XR) RESULT DATATYPE
15781: #
15782: dtype: #prc # entry point
15783: cmpl (r9),$b$pdt # jump if prog.defined
15784: beqlu dtyp1
15785: movl (r9),r9 # load type word
15786: movzwl -2(r9),r9 # get entry point id (block code)
15787: moval 0[r9],r9 # convert to byte offset
15788: movl l^scnmt(r9),r9 # load table entry
15789: rsb # exit to dtype caller
15790: #
15791: # HERE IF PROGRAM DEFINED
15792: #
15793: dtyp1: movl 4*pddfp(r9),r9 # point to dfblk
15794: movl 4*dfnam(r9),r9 # get datatype name from dfblk
15795: rsb # return to dtype caller
15796: #enp # end procedure dtype
15797: #page
15798: #
15799: # DUMPR -- PRINT DUMP OF STORAGE
15800: #
15801: # (XR) DUMP ARGUMENT (SEE BELOW)
15802: # JSR DUMPR CALL TO PRINT DUMP
15803: # (XR,XL) DESTROYED
15804: # (WA,WB,WC,RA) DESTROYED
15805: #
15806: # THE DUMP ARGUMENT HAS THE FOLLOWING SIGNIFICANCE
15807: #
15808: # DMARG = 0 NO DUMP PRINTED
15809: # DMARG = 1 PARTIAL DUMP (NAT VARS, KEYWORDS)
15810: # DMARG EQ 2 FULL DUMP (INCL ARRAYS ETC.)
15811: # DMARG GE 3 CORE DUMP
15812: #
15813: # SINCE DUMPR SCRAMBLES STORE, IT IS NOT PERMISSIBLE TO
15814: # COLLECT IN MID-DUMP. HENCE A COLLECT IS DONE INITIALLY
15815: # AND THEN IF STORE RUNS OUT AN ERROR MESSAGE IS PRODUCED.
15816: #
15817: dumpr: #prc # entry point
15818: tstl r9 # skip dump if argument is zero
15819: bnequ 0f
15820: jmp dmp28
15821: 0:
15822: cmpl r9,$num02 # jump if core dump required
15823: blequ 0f
15824: jmp dmp29
15825: 0:
15826: clrl r10 # clear xl
15827: clrl r7 # zero move offset
15828: movl r9,dmarg # save dump argument
15829: jsb gbcol # collect garbage
15830: jsb prtpg # eject printer
15831: movl $dmhdv,r9 # point to heading for variables
15832: jsb prtst # print it
15833: jsb prtnl # terminate print line
15834: jsb prtnl # and print a blank line
15835: #
15836: # FIRST ALL NATURAL VARIABLE BLOCKS (VRBLK) WHOSE VALUES
15837: # ARE NON-NULL ARE LINKED IN LEXICAL ORDER USING DMVCH AS
15838: # THE CHAIN HEAD AND CHAINING THROUGH THE VRGET FIELDS.
15839: # NOTE THAT THIS SCRAMBLES STORE IF THE PROCESS IS
15840: # INTERRUPTED BEFORE COMPLETION E.G. BY EXCEEDING TIME OR
15841: # PRINT LIMITS. SINCE THE SUBSEQUENT CORE DUMPS AND
15842: # FAILURES IF EXECUTION IS RESUMED ARE VERY CONFUSING, THE
15843: # EXECUTION TIME ERROR ROUTINE CHECKS FOR THIS EVENT AND
15844: # ATTEMPTS AN UNSCRAMBLE. SIMILAR PRECAUTIONS SHOULD BE
15845: # OBSERVED IF TRANSLATE TIME DUMPING IS IMPLEMENTED.
15846: #
15847: clrl dmvch # set null chain to start
15848: movl hshtb,r6 # point to hash table
15849: #
15850: # LOOP THROUGH HEADERS IN HASH TABLE
15851: #
15852: dmp00: movl r6,r9 # copy hash bucket pointer
15853: addl2 $4,r6 # bump pointer
15854: subl2 $4*vrnxt,r9 # set offset to merge
15855: #
15856: # LOOP THROUGH VRBLKS ON ONE CHAIN
15857: #
15858: dmp01: movl 4*vrnxt(r9),r9 # point to next vrblk on chain
15859: bnequ 0f # jump if end of this hash chain
15860: jmp dmp09
15861: 0:
15862: movl r9,r10 # else copy vrblk pointer
15863: #page
15864: #
15865: # DUMPR (CONTINUED)
15866: #
15867: # LOOP TO FIND VALUE AND SKIP IF NULL
15868: #
15869: dmp02: movl 4*vrval(r10),r10# load value
15870: cmpl r10,$nulls # loop for next vrblk if null value
15871: beqlu dmp01
15872: cmpl (r10),$b$trt # loop back if value is trapped
15873: beqlu dmp02
15874: #
15875: # NON-NULL VALUE, PREPARE TO SEARCH CHAIN
15876: #
15877: movl r9,r8 # save vrblk pointer
15878: addl2 $4*vrsof,r9 # adjust ptr to be like scblk ptr
15879: tstl 4*sclen(r9) # jump if non-system variable
15880: bnequ dmp03
15881: movl 4*vrsvo(r9),r9 # else load ptr to name in svblk
15882: #
15883: # HERE WITH NAME POINTER FOR NEW BLOCK IN XR
15884: #
15885: dmp03: movl r9,r7 # save pointer to chars
15886: movl r6,dmpsv # save hash bucket pointer
15887: movl $dmvch,r6 # point to chain head
15888: #
15889: # LOOP TO SEARCH CHAIN FOR CORRECT INSERTION POINT
15890: #
15891: dmp04: movl r6,dmpch # save chain pointer
15892: movl r6,r10 # copy it
15893: movl (r10),r9 # load pointer to next entry
15894: bnequ 0f # jump if end of chain to insert
15895: jmp dmp08
15896: 0:
15897: addl2 $4*vrsof,r9 # else get name ptr for chained vrblk
15898: tstl 4*sclen(r9) # jump if not system variable
15899: bnequ dmp05
15900: movl 4*vrsvo(r9),r9 # else point to name in svblk
15901: #
15902: # HERE PREPARE TO COMPARE THE NAMES
15903: #
15904: # (WA) SCRATCH
15905: # (WB) POINTER TO STRING OF ENTERING VRBLK
15906: # (WC) POINTER TO ENTERING VRBLK
15907: # (XR) POINTER TO STRING OF CURRENT BLOCK
15908: # (XL) SCRATCH
15909: #
15910: dmp05: movl r7,r10 # point to entering vrblk string
15911: movl 4*sclen(r10),r6 # load its length
15912: movab cfp$f(r10),r10 # point to chars of entering string
15913: cmpl r6,4*sclen(r9) # jump if entering length high
15914: bgequ dmp06
15915: movab cfp$f(r9),r9 # else point to chars of old string
15916: jsb sbcmc # compare, insert if new is llt old
15917: .long dmp08
15918: .long dmp07
15919: jmp dmp08 # or if leq (we had shorter length)
15920: #
15921: # HERE WHEN NEW LENGTH IS LONGER THAN OLD LENGTH
15922: #
15923: dmp06: movl 4*sclen(r9),r6 # load shorter length
15924: movab cfp$f(r9),r9 # point to chars of old string
15925: jsb sbcmc # compare, insert if new one low
15926: .long dmp08
15927: .long dmp07
15928: #page
15929: #
15930: # DUMPR (CONTINUED)
15931: #
15932: # HERE WE MOVE OUT ON THE CHAIN
15933: #
15934: dmp07: movl dmpch,r10 # copy chain pointer
15935: movl (r10),r6 # move to next entry on chain
15936: jmp dmp04 # loop back
15937: #
15938: # HERE AFTER LOCATING THE PROPER INSERTION POINT
15939: #
15940: dmp08: movl dmpch,r10 # copy chain pointer
15941: movl dmpsv,r6 # restore hash bucket pointer
15942: movl r8,r9 # restore vrblk pointer
15943: movl (r10),4*vrget(r9)# link vrblk to rest of chain
15944: movl r9,(r10) # link vrblk into current chain loc
15945: jmp dmp01 # loop back for next vrblk
15946: #
15947: # HERE AFTER PROCESSING ALL VRBLKS ON ONE CHAIN
15948: #
15949: dmp09: cmpl r6,hshte # loop back if more buckets to go
15950: beqlu 0f
15951: jmp dmp00
15952: 0:
15953: #
15954: # LOOP TO GENERATE DUMP OF NATURAL VARIABLE VALUES
15955: #
15956: dmp10: movl dmvch,r9 # load pointer to next entry on chain
15957: beqlu dmp11 # jump if end of chain
15958: movl (r9),dmvch # else update chain ptr to next entry
15959: jsb setvr # restore vrget field
15960: movl r9,r10 # copy vrblk pointer (name base)
15961: movl $4*vrval,r6 # set offset for vrblk name
15962: jsb prtnv # print name = value
15963: jmp dmp10 # loop back till all printed
15964: #
15965: # PREPARE TO PRINT KEYWORDS
15966: #
15967: dmp11: jsb prtnl # print blank line
15968: jsb prtnl # and another
15969: movl $dmhdk,r9 # point to keyword heading
15970: jsb prtst # print heading
15971: jsb prtnl # end line
15972: jsb prtnl # print one blank line
15973: movl $vdmkw,r10 # point to list of keyword svblk ptrs
15974: #page
15975: #
15976: # DUMPR (CONTINUED)
15977: #
15978: # LOOP TO DUMP KEYWORD VALUES
15979: #
15980: dmp12: movl (r10)+,r9 # load next svblk ptr from table
15981: beqlu dmp13 # jump if end of list
15982: movl $ch$am,r6 # load ampersand
15983: jsb prtch # print ampersand
15984: jsb prtst # print keyword name
15985: movl 4*svlen(r9),r6 # load name length from svblk
15986: movab 3+(4*svchs)(r6),r6 # get length of name
15987: bicl2 $3,r6
15988: addl2 r6,r9 # point to svknm field
15989: movl (r9),dmpkn # store in dummy kvblk
15990: movl $tmbeb,r9 # point to blank-equal-blank
15991: jsb prtst # print it
15992: movl r10,dmpsv # save table pointer
15993: movl $dmpkb,r10 # point to dummy kvblk
15994: movl $4*kvvar,r6 # set zero offset
15995: jsb acess # get keyword value
15996: .long invalid$ # failure is impossible
15997: jsb prtvl # print keyword value
15998: jsb prtnl # terminate print line
15999: movl dmpsv,r10 # restore table pointer
16000: jmp dmp12 # loop back till all printed
16001: #
16002: # HERE AFTER COMPLETING PARTIAL DUMP
16003: #
16004: dmp13: cmpl dmarg,$num01 # exit if partial dump complete
16005: bnequ 0f
16006: jmp dmp27
16007: 0:
16008: movl dnamb,r9 # else point to first dynamic block
16009: #
16010: # LOOP THROUGH BLOCKS IN DYNAMIC STORAGE
16011: #
16012: dmp14: cmpl r9,dnamp # jump if end of used region
16013: bnequ 0f
16014: jmp dmp27
16015: 0:
16016: movl (r9),r6 # else load first word of block
16017: cmpl r6,$b$vct # jump if vector
16018: beqlu dmp16
16019: cmpl r6,$b$art # jump if array
16020: beqlu dmp17
16021: cmpl r6,$b$pdt # jump if program defined
16022: beqlu dmp18
16023: cmpl r6,$b$tbt # jump if table
16024: beqlu dmp19
16025: cmpl r6,$b$bct # jump if buffer
16026: bnequ 0f
16027: jmp dmp30
16028: 0:
16029: #
16030: # MERGE HERE TO MOVE TO NEXT BLOCK
16031: #
16032: dmp15: jsb blkln # get length of block
16033: addl2 r6,r9 # point past this block
16034: jmp dmp14 # loop back for next block
16035: #page
16036: #
16037: # DUMPR (CONTINUED)
16038: #
16039: # HERE FOR VECTOR
16040: #
16041: dmp16: movl $4*vcvls,r7 # set offset to first value
16042: jmp dmp19 # jump to merge
16043: #
16044: # HERE FOR ARRAY
16045: #
16046: dmp17: movl 4*arofs(r9),r7 # set offset to arpro field
16047: addl2 $4,r7 # bump to get offset to values
16048: jmp dmp19 # jump to merge
16049: #
16050: # HERE FOR PROGRAM DEFINED
16051: #
16052: dmp18: movl $4*pdfld,r7 # point to values, merge
16053: #
16054: # HERE FOR TABLE (OTHERS MERGE)
16055: #
16056: dmp19: tstl 4*idval(r9) # ignore block if zero id value
16057: bnequ 0f
16058: jmp dmp15
16059: 0:
16060: jsb blkln # else get block length
16061: movl r9,r10 # copy block pointer
16062: movl r6,dmpsv # save length
16063: movl r7,r6 # copy offset to first value
16064: jsb prtnl # print blank line
16065: movl r6,dmpsa # preserve offset
16066: jsb prtvl # print block value (for title)
16067: movl dmpsa,r6 # recover offset
16068: jsb prtnl # end print line
16069: cmpl (r9),$b$tbt # jump if table
16070: beqlu dmp22
16071: subl2 $4,r6 # point before first word
16072: #
16073: # LOOP TO PRINT CONTENTS OF ARRAY, VECTOR, OR PROGRAM DEF
16074: #
16075: dmp20: movl r10,r9 # copy block pointer
16076: addl2 $4,r6 # bump offset
16077: addl2 r6,r9 # point to next value
16078: cmpl r6,dmpsv # exit if end (xr past block)
16079: bnequ 0f
16080: jmp dmp14
16081: 0:
16082: subl2 $4*vrval,r9 # subtract offset to merge into loop
16083: #
16084: # LOOP TO FIND VALUE AND IGNORE NULLS
16085: #
16086: dmp21: movl 4*vrval(r9),r9 # load next value
16087: cmpl r9,$nulls # loop back if null value
16088: beqlu dmp20
16089: cmpl (r9),$b$trt # loop back if trapped
16090: beqlu dmp21
16091: jsb prtnv # else print name = value
16092: jmp dmp20 # loop back for next field
16093: #page
16094: #
16095: # DUMPR (CONTINUED)
16096: #
16097: # HERE TO DUMP A TABLE
16098: #
16099: dmp22: movl $4*tbbuk,r8 # set offset to first bucket
16100: movl $4*teval,r6 # set name offset for all teblks
16101: #
16102: # LOOP THROUGH TABLE BUCKETS
16103: #
16104: dmp23: movl r10,-(sp) # save tbblk pointer
16105: addl2 r8,r10 # point to next bucket header
16106: addl2 $4,r8 # bump bucket offset
16107: subl2 $4*tenxt,r10 # subtract offset to merge into loop
16108: #
16109: # LOOP TO PROCESS TEBLKS ON ONE CHAIN
16110: #
16111: dmp24: movl 4*tenxt(r10),r10# point to next teblk
16112: cmpl r10,(sp) # jump if end of chain
16113: beqlu dmp26
16114: movl r10,r9 # else copy teblk pointer
16115: #
16116: # LOOP TO FIND VALUE AND IGNORE IF NULL
16117: #
16118: dmp25: movl 4*teval(r9),r9 # load next value
16119: cmpl r9,$nulls # ignore if null value
16120: beqlu dmp24
16121: cmpl (r9),$b$trt # loop back if trapped
16122: beqlu dmp25
16123: movl r8,dmpsv # else save offset pointer
16124: jsb prtnv # print name = value
16125: movl dmpsv,r8 # reload offset
16126: jmp dmp24 # loop back for next teblk
16127: #
16128: # HERE TO MOVE TO NEXT HASH CHAIN
16129: #
16130: dmp26: movl (sp)+,r10 # restore tbblk pointer
16131: cmpl r8,4*tblen(r10) # loop back if more buckets to go
16132: bnequ dmp23
16133: movl r10,r9 # else copy table pointer
16134: addl2 r8,r9 # point to following block
16135: jmp dmp14 # loop back to process next block
16136: #
16137: # HERE AFTER COMPLETING DUMP
16138: #
16139: dmp27: jsb prtpg # eject printer
16140: #
16141: # MERGE HERE IF NO DUMP GIVEN (DMARG=0)
16142: #
16143: dmp28: rsb # return to dump caller
16144: #
16145: # CALL SYSTEM CORE DUMP ROUTINE
16146: #
16147: dmp29: jsb sysdm # call it
16148: jmp dmp28 # return
16149: #page
16150: #
16151: # DUMPR (CONTINUED)
16152: #
16153: # HERE TO DUMP BUFFER BLOCK
16154: #
16155: dmp30: jsb prtnl # print blank line
16156: jsb prtvl # print value id for title
16157: jsb prtnl # force new line
16158: movl $ch$dq,r6 # load double quote
16159: jsb prtch # print it
16160: movl 4*bclen(r9),r8 # load defined length
16161: beqlu dmp32 # skip characters if none
16162: # load count for loop
16163: movl r9,r7 # save bcblk ptr
16164: movl 4*bcbuf(r9),r9 # point to bfblk
16165: movab cfp$f(r9),r9 # get set to load characters
16166: #
16167: # LOOP HERE STUFFING CHARACTERS IN OUTPUT STREAM
16168: #
16169: dmp31: movzbl (r9)+,r6 # get next character
16170: jsb prtch # stuff it
16171: sobgtr r8,dmp31 # branch for next one
16172: movl r7,r9 # restore bcblk pointer
16173: #
16174: # MERGE TO STUFF CLOSING QUOTE MARK
16175: #
16176: dmp32: movl $ch$dq,r6 # stuff quote
16177: jsb prtch # print it
16178: jsb prtnl # print new line
16179: movl (r9),r6 # get first wd for blkln
16180: jmp dmp15 # merge to get next block
16181: #enp # end procedure dumpr
16182: #page
16183: #
16184: # ERMSG -- PRINT ERROR CODE AND ERROR MESSAGE
16185: #
16186: # KVERT ERROR CODE
16187: # JSR ERMSG CALL TO PRINT MESSAGE
16188: # (XR,XL,WA,WB,WC,IA) DESTROYED
16189: #
16190: ermsg: #prc # entry point
16191: jsb prtis # print error ptr or blank line
16192: movl kvert,r6 # load error code
16193: movl $ermms,r9 # point to error message /error/
16194: jsb prtst # print it
16195: jsb ertex # get error message text
16196: addl2 $thsnd,r6 # bump error code for print
16197: movl r6,r5 # fail code in int acc
16198: jsb prtin # print code (now have error1xxx)
16199: movl prbuf,r10 # point to print buffer
16200: movl $num05,r11 # [get in scratch register]
16201: movab cfp$f(r10)[r11],r10 # point to the 1
16202: movl $ch$bl,r6 # load a blank
16203: movb r6,(r10) # store blank over 1 (error xxx)
16204: #csc r10 # complete store characters
16205: clrl r10 # clear garbage pointer in xl
16206: movl r9,r6 # keep error text
16207: movl $ermns,r9 # point to / -- /
16208: jsb prtst # print it
16209: movl r6,r9 # get error text again
16210: jsb prtst # print error message text
16211: jsb prtis # print line
16212: jsb prtis # print blank line
16213: rsb # return to ermsg caller
16214: #enp # end procedure ermsg
16215: #page
16216: #
16217: # ERTEX -- GET ERROR MESSAGE TEXT
16218: #
16219: # (WA) ERROR CODE
16220: # JSR ERTEX CALL TO GET ERROR TEXT
16221: # (XR) PTR TO ERROR TEXT IN DYNAMIC
16222: # (R$ETX) COPY OF PTR TO ERROR TEXT
16223: # (XL,WC,IA) DESTROYED
16224: #
16225: ertex: #prc # entry point
16226: movl r6,ertwa # save wa
16227: movl r7,ertwb # save wb
16228: jsb sysem # get failure message text
16229: movl r9,r10 # copy pointer to it
16230: movl 4*sclen(r9),r6 # get length of string
16231: beqlu ert02 # jump if null
16232: clrl r7 # offset of zero
16233: jsb sbstr # copy into dynamic store
16234: movl r9,r$etx # store for relocation
16235: #
16236: # RETURN
16237: #
16238: ert01: movl ertwb,r7 # restore wb
16239: movl ertwa,r6 # restore wa
16240: rsb # return to caller
16241: #
16242: # RETURN ERRTEXT CONTENTS INSTEAD OF NULL
16243: #
16244: ert02: movl r$etx,r9 # get errtext
16245: jmp ert01 # return
16246: #enp
16247: #page
16248: #
16249: # EVALI -- EVALUATE INTEGER ARGUMENT
16250: #
16251: # EVALI IS USED BY PATTERN PRIMITIVES LEN,TAB,RTAB,POS,RPOS
16252: # WHEN THEIR ARGUMENT IS AN EXPRESSION VALUE.
16253: #
16254: # (XR) NODE POINTER
16255: # (WB) CURSOR
16256: # JSR EVALI CALL TO EVALUATE INTEGER
16257: # PPM LOC TRANSFER LOC FOR NON-INTEGER ARG
16258: # PPM LOC TRANSFER LOC FOR OUT OF RANGE ARG
16259: # PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
16260: # PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL
16261: # (THE NORMAL RETURN IS NEVER TAKEN)
16262: # (XR) PTR TO NODE WITH INTEGER ARGUMENT
16263: # (WC,XL,RA) DESTROYED
16264: #
16265: # ON RETURN, THE NODE POINTED TO HAS THE INTEGER ARGUMENT
16266: # IN PARM1 AND THE PROPER SUCCESSOR POINTER IN PTHEN.
16267: # THIS ALLOWS MERGING WITH THE NORMAL (INTEGER ARG) CASE.
16268: #
16269: evali: #prc # entry point (recursive)
16270: jsb evalp # evaluate expression
16271: .long evli1 # jump on failure
16272: movl r10,-(sp) # stack result for gtsmi
16273: movl 4*pthen(r9),r10 # load successor pointer
16274: jsb gtsmi # convert arg to small integer
16275: .long evli2 # jump if not integer
16276: .long evli3 # jump if out of range
16277: movl r9,evliv # store result in special dummy node
16278: movl r10,evlis # store successor pointer
16279: movl $evlin,r9 # point to dummy node with result
16280: addl3 $4*3,(sp)+,r11 # take successful exit
16281: jmp *(r11)+
16282: #
16283: # HERE IF EVALUATION FAILS
16284: #
16285: evli1: addl3 $4*2,(sp)+,r11 # take failure return
16286: jmp *(r11)+
16287: #
16288: # HERE IF ARGUMENT IS NOT INTEGER
16289: #
16290: evli2: movl (sp)+,r11 # take non-integer error exit
16291: jmp *(r11)+
16292: #
16293: # HERE IF ARGUMENT IS OUT OF RANGE
16294: #
16295: evli3: addl3 $4*1,(sp)+,r11 # take out-of-range error exit
16296: jmp *(r11)+
16297: #enp # end procedure evali
16298: #page
16299: #
16300: # EVALP -- EVALUATE EXPRESSION DURING PATTERN MATCH
16301: #
16302: # EVALP IS USED TO EVALUATE AN EXPRESSION (BY VALUE) DURING
16303: # A PATTERN MATCH. THE EFFECT IS LIKE EVALX, BUT PATTERN
16304: # VARIABLES ARE STACKED AND RESTORED IF NECESSARY.
16305: #
16306: # EVALP ALSO DIFFERS FROM EVALX IN THAT IF THE RESULT IS
16307: # AN EXPRESSION IT IS REEVALUATED. THIS OCCURS REPEATEDLY.
16308: #
16309: # (XR) NODE POINTER
16310: # (WB) PATTERN MATCH CURSOR
16311: # JSR EVALP CALL TO EVALUATE EXPRESSION
16312: # PPM LOC TRANSFER LOC IF EVALUATION FAILS
16313: # (XL) RESULT
16314: # (WA) FIRST WORD OF RESULT BLOCK
16315: # (XR,WB) DESTROYED (FAILURE CASE ONLY)
16316: # (WC,RA) DESTROYED
16317: #
16318: # THE EXPRESSION POINTER IS STORED IN PARM1 OF THE NODE
16319: #
16320: # CONTROL RETURNS TO FAILP ON FAILURE OF EVALUATION
16321: #
16322: evalp: #prc # entry point (recursive)
16323: movl 4*parm1(r9),r10 # load expression pointer
16324: cmpl (r10),$b$exl # jump if exblk case
16325: beqlu evlp1
16326: #
16327: # HERE FOR CASE OF SEBLK
16328: #
16329: # WE CAN GIVE A FAST RETURN IF THE VALUE OF THE VRBLK IS
16330: # NOT AN EXPRESSION AND IS NOT TRAPPED.
16331: #
16332: movl 4*sevar(r10),r10# load vrblk pointer
16333: movl 4*vrval(r10),r10# load value of vrblk
16334: movl (r10),r6 # load first word of value
16335: cmpl r6,$b$t$$ # jump if not seblk, trblk or exblk
16336: bgequ evlp3
16337: #
16338: # HERE FOR EXBLK OR SEBLK WITH EXPR VALUE OR TRAPPED VALUE
16339: #
16340: evlp1: movl r9,-(sp) # stack node pointer
16341: movl r7,-(sp) # stack cursor
16342: movl r$pms,-(sp) # stack subject string pointer
16343: movl pmssl,-(sp) # stack subject string length
16344: movl pmdfl,-(sp) # stack dot flag
16345: movl pmhbs,-(sp) # stack history stack base pointer
16346: movl 4*parm1(r9),r9 # load expression pointer
16347: #page
16348: #
16349: # EVALP (CONTINUED)
16350: #
16351: # LOOP BACK HERE TO REEVALUATE EXPRESSION RESULT
16352: #
16353: evlp2: clrl r7 # set flag for by value
16354: jsb evalx # evaluate expression
16355: .long evlp4 # jump on failure
16356: movl (r9),r6 # else load first word of value
16357: cmpl r6,$b$e$$ # loop back to reevaluate expression
16358: blequ evlp2
16359: #
16360: # HERE TO RESTORE PATTERN VALUES AFTER SUCCESSFUL EVAL
16361: #
16362: movl r9,r10 # copy result pointer
16363: movl (sp)+,pmhbs # restore history stack base pointer
16364: movl (sp)+,pmdfl # restore dot flag
16365: movl (sp)+,pmssl # restore subject string length
16366: movl (sp)+,r$pms # restore subject string pointer
16367: movl (sp)+,r7 # restore cursor
16368: movl (sp)+,r9 # restore node pointer
16369: #
16370: # COMMON EXIT POINT
16371: #
16372: evlp3: addl2 $4*1,(sp) # return to evalp caller
16373: rsb
16374: #
16375: # HERE FOR FAILURE DURING EVALUATION
16376: #
16377: evlp4: movl (sp)+,pmhbs # restore history stack base pointer
16378: movl (sp)+,pmdfl # restore dot flag
16379: movl (sp)+,pmssl # restore subject string length
16380: movl (sp)+,r$pms # restore subject string pointer
16381: addl2 $4*num02,sp # remove node ptr, cursor
16382: movl (sp)+,r11 # take failure exit
16383: jmp *(r11)+
16384: #enp # end procedure evalp
16385: #page
16386: #
16387: # EVALS -- EVALUATE STRING ARGUMENT
16388: #
16389: # EVALS IS USED BY SPAN, ANY, NOTANY, BREAK, BREAKX WHEN
16390: # THEY ARE PASSED AN EXPRESSION ARGUMENT.
16391: #
16392: # (XR) NODE POINTER
16393: # (WB) CURSOR
16394: # JSR EVALS CALL TO EVALUATE STRING
16395: # PPM LOC TRANSFER LOC FOR NON-STRING ARG
16396: # PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
16397: # PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL
16398: # (THE NORMAL RETURN IS NEVER TAKEN)
16399: # (XR) PTR TO NODE WITH PARMS SET
16400: # (XL,WC,RA) DESTROYED
16401: #
16402: # ON RETURN, THE NODE POINTED TO HAS A CHARACTER TABLE
16403: # POINTER IN PARM1 AND A BIT MASK IN PARM2. THE PROPER
16404: # SUCCESSOR IS STORED IN PTHEN OF THIS NODE. THUS IT IS
16405: # OK FOR MERGING WITH THE NORMAL (MULTI-CHAR STRING) CASE.
16406: #
16407: evals: #prc # entry point (recursive)
16408: jsb evalp # evaluate expression
16409: .long evls1 # jump if evaluation fails
16410: movl 4*pthen(r9),-(sp)# save successor pointer
16411: movl r7,-(sp) # save cursor
16412: movl r10,-(sp) # stack result ptr for patst
16413: clrl r7 # dummy pcode for one char string
16414: clrl r8 # dummy pcode for expression arg
16415: movl $p$brk,r10 # appropriate pcode for our use
16416: jsb patst # call routine to build node
16417: .long evls2 # jump if not string
16418: movl (sp)+,r7 # restore cursor
16419: movl (sp)+,4*pthen(r9)# store successor pointer
16420: addl3 $4*2,(sp)+,r11 # take success return
16421: jmp *(r11)+
16422: #
16423: # HERE IF EVALUATION FAILS
16424: #
16425: evls1: addl3 $4*1,(sp)+,r11 # take failure return
16426: jmp *(r11)+
16427: #
16428: # HERE IF ARGUMENT IS NOT STRING
16429: #
16430: evls2: addl2 $4*num02,sp # pop successor and cursor
16431: movl (sp)+,r11 # take non-string error exit
16432: jmp *(r11)+
16433: #enp # end procedure evals
16434: #page
16435: #
16436: # EVALX -- EVALUATE EXPRESSION
16437: #
16438: # EVALX IS CALLED TO EVALUATE AN EXPRESSION
16439: #
16440: # (XR) POINTER TO EXBLK OR SEBLK
16441: # (WB) 0 IF BY VALUE, 1 IF BY NAME
16442: # JSR EVALX CALL TO EVALUATE EXPRESSION
16443: # PPM LOC TRANSFER LOC IF EVALUATION FAILS
16444: # (XR) RESULT IF CALLED BY VALUE
16445: # (XL,WA) RESULT NAME BASE,OFFSET IF BY NAME
16446: # (XR) DESTROYED (NAME CASE ONLY)
16447: # (XL,WA) DESTROYED (VALUE CASE ONLY)
16448: # (WB,WC,RA) DESTROYED
16449: #
16450: evalx: #prc # entry point, recursive
16451: cmpl (r9),$b$exl # jump if exblk case
16452: beqlu evlx2
16453: #
16454: # HERE FOR SEBLK
16455: #
16456: movl 4*sevar(r9),r10 # load vrblk pointer (name base)
16457: movl $4*vrval,r6 # set name offset
16458: tstl r7 # jump if called by name
16459: beqlu 0f
16460: jmp evlx1
16461: 0:
16462: jsb acess # call routine to access value
16463: .long evlx9 # jump if failure on access
16464: #
16465: # MERGE HERE TO EXIT FOR SEBLK CASE
16466: #
16467: evlx1: addl2 $4*1,(sp) # return to evalx caller
16468: rsb
16469: #page
16470: #
16471: # EVALX (CONTINUED)
16472: #
16473: # HERE FOR FULL EXPRESSION (EXBLK) CASE
16474: #
16475: # IF AN ERROR OCCURS IN THE EXPRESSION CODE AT EXECUTION
16476: # TIME, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
16477: # WITHOUT RETURNING TO THIS ROUTINE.
16478: # THE FOLLOWING ENTRIES ARE MADE ON THE STACK BEFORE
16479: # GIVING CONTROL TO THE EXPRESSION CODE
16480: #
16481: # EVALX RETURN POINT
16482: # SAVED VALUE OF R$COD
16483: # CODE POINTER (-R$COD)
16484: # SAVED VALUE OF FLPTR
16485: # 0 IF BY VALUE, 1 IF BY NAME
16486: # FLPTR --------------- *EXFLC, FAIL OFFSET IN EXBLK
16487: #
16488: evlx2: movl r3,r8 # get code pointer
16489: movl r$cod,r6 # load code block pointer
16490: subl2 r6,r8 # get code pointer as offset
16491: movl r6,-(sp) # stack old code block pointer
16492: movl r8,-(sp) # stack relative code offset
16493: movl flptr,-(sp) # stack old failure pointer
16494: movl r7,-(sp) # stack name/value indicator
16495: movl $4*exflc,-(sp) # stack new fail offset
16496: movl flptr,gtcef # keep in case of error
16497: movl r$cod,r$gtc # keep code block pointer similarly
16498: movl sp,flptr # set new failure pointer
16499: movl r9,r$cod # set new code block pointer
16500: movl kvstn,4*exstm(r9)# remember stmnt number
16501: addl2 $4*excod,r9 # point to first code word
16502: movl r9,r3 # set code pointer
16503: cmpl stage,$stgxt # jump if not execution time
16504: beqlu 0f
16505: jmp exits
16506: 0:
16507: movl $stgee,stage # evaluating expression
16508: jmp exits # jump to execute first code word
16509: #page
16510: #
16511: # EVALX (CONTINUED)
16512: #
16513: # COME HERE IF SUCCESSFUL RETURN BY VALUE (SEE O$RVL)
16514: #
16515: evlx3: movl (sp)+,r9 # load value
16516: tstl 4*1(sp) # jump if called by value
16517: beqlu evlx5
16518: jmp er_249 # expression evaluated by name returned value
16519: #
16520: # HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM)
16521: #
16522: evlx4: movl (sp)+,r6 # load name offset
16523: movl (sp)+,r10 # load name base
16524: tstl 4*1(sp) # jump if called by name
16525: bnequ evlx5
16526: jsb acess # else access value first
16527: .long evlx6 # jump if failure during access
16528: #
16529: # HERE AFTER LOADING CORRECT RESULT INTO XR OR XL,WA
16530: #
16531: evlx5: clrl r7 # note successful
16532: jmp evlx7 # merge
16533: #
16534: # HERE FOR FAILURE IN EXPRESSION EVALUATION (SEE O$FEX)
16535: #
16536: evlx6: movl sp,r7 # note unsuccessful
16537: #
16538: # RESTORE ENVIRONMENT
16539: #
16540: evlx7: cmpl stage,$stgee # skip if was not previously xt
16541: bnequ evlx8
16542: movl $stgxt,stage # execute time
16543: #
16544: # MERGE WITH STAGE SET UP
16545: #
16546: evlx8: addl2 $4*num02,sp # pop name/value indicator, *exfal
16547: movl (sp)+,flptr # restore old failure pointer
16548: movl (sp)+,r8 # load code offset
16549: addl2 (sp),r8 # make code pointer absolute
16550: movl (sp)+,r$cod # restore old code block pointer
16551: movl r8,r3 # restore old code pointer
16552: tstl r7 # jump for successful return
16553: bnequ 0f
16554: jmp evlx1
16555: 0:
16556: #
16557: # MERGE HERE FOR FAILURE IN SEBLK CASE
16558: #
16559: evlx9: movl (sp)+,r11 # take failure exit
16560: jmp *(r11)+
16561: #enp # end of procedure evalx
16562: #page
16563: #
16564: # EXBLD -- BUILD EXBLK
16565: #
16566: # EXBLD IS USED TO BUILD AN EXPRESSION BLOCK FROM THE
16567: # CODE COMPILED MOST RECENTLY IN THE CURRENT CCBLK.
16568: #
16569: # (XL) OFFSET IN CCBLK TO START OF CODE
16570: # (WB) INTEGER IN RANGE 0 LE N LE MXLEN
16571: # JSR EXBLD CALL TO BUILD EXBLK
16572: # (XR) PTR TO CONSTRUCTED EXBLK
16573: # (WA,WB,XL) DESTROYED
16574: #
16575: exbld: #prc # entry point
16576: movl r10,r6 # copy offset to start of code
16577: subl2 $4*excod,r6 # calc reduction in offset in exblk
16578: movl r6,-(sp) # stack for later
16579: movl cwcof,r6 # load final offset
16580: subl2 r10,r6 # compute length of code
16581: addl2 $4*exsi$,r6 # add space for standard fields
16582: jsb alloc # allocate space for exblk
16583: movl r9,-(sp) # save pointer to exblk
16584: movl $b$exl,4*extyp(r9) # store type word
16585: clrl 4*exstm(r9) # zeroise stmnt number field
16586: movl r6,4*exlen(r9) # store length
16587: movl $ofex$,4*exflc(r9) # store failure word
16588: addl2 $4*exsi$,r9 # set xr for sysmw
16589: movl r10,cwcof # reset offset to start of code
16590: addl2 r$ccb,r10 # point to start of code
16591: subl2 $4*exsi$,r6 # length of code to move
16592: movl r6,-(sp) # stack length of code
16593: jsb sbmvw # move code to exblk
16594: movl (sp)+,r6 # get length of code
16595: ashl $-2,r6,r6 # convert byte count to word count
16596: # prepare counter for loop
16597: movl (sp),r10 # copy exblk ptr, dont unstack
16598: addl2 $4*excod,r10 # point to code itself
16599: movl 4*1(sp),r7 # get reduction in offset
16600: #
16601: # THIS LOOP SEARCHES FOR NEGATION AND SELECTION CODE SO
16602: # THAT THE OFFSETS COMPUTED WHILST CODE WAS IN CODE BLOCK
16603: # CAN BE TRANSFORMED TO REDUCED VALUES APPLICABLE IN AN
16604: # EXBLK.
16605: #
16606: exbl1: movl (r10)+,r9 # get next code word
16607: cmpl r9,$osla$ # jump if selection found
16608: beqlu exbl3
16609: cmpl r9,$onta$ # jump if negation found
16610: beqlu exbl3
16611: sobgtr r6,exbl1 # loop to end of code
16612: #
16613: # NO SELECTION FOUND OR MERGE TO EXIT ON TERMINATION
16614: #
16615: exbl2: movl (sp)+,r9 # pop exblk ptr into xr
16616: movl (sp)+,r10 # pop reduction constant
16617: rsb # return to caller
16618: #page
16619: #
16620: # EXBLD (CONTINUED)
16621: #
16622: # SELECTION OR NEGATION FOUND
16623: # REDUCE THE OFFSETS AS NEEDED. OFFSETS OCCUR IN WORDS
16624: # FOLLOWING CODE WORDS -
16625: # =ONTA$, =OSLA$, =OSLB$, =OSLC$
16626: #
16627: exbl3: subl2 r7,(r10)+ # adjust offset
16628: sobgtr r6,exbl4 # decrement count
16629: #
16630: exbl4: sobgtr r6,exbl5 # decrement count
16631: #
16632: # CONTINUE SEARCH FOR MORE OFFSETS
16633: #
16634: exbl5: movl (r10)+,r9 # get next code word
16635: cmpl r9,$osla$ # jump if offset found
16636: beqlu exbl3
16637: cmpl r9,$oslb$ # jump if offset found
16638: beqlu exbl3
16639: cmpl r9,$oslc$ # jump if offset found
16640: beqlu exbl3
16641: cmpl r9,$onta$ # jump if offset found
16642: beqlu exbl3
16643: sobgtr r6,exbl5 # loop
16644: jmp exbl2 # merge to return
16645: #enp # end procedure exbld
16646: #page
16647: #
16648: # EXPAN -- ANALYZE EXPRESSION
16649: #
16650: # THE EXPRESSION ANALYZER (EXPAN) PROCEDURE IS USED TO SCAN
16651: # AN EXPRESSION AND CONVERT IT INTO A TREE REPRESENTATION.
16652: # SEE DESCRIPTIONS OF CMBLK, CUBLK, CBBLK IN THE STRUCTURES
16653: # SECTION FOR DETAILED FORMAT OF TREE BLOCKS.
16654: #
16655: # THE ANALYZER USES A SIMPLE PRECEDENCE SCHEME IN WHICH
16656: # OPERANDS AND OPERATORS ARE PLACED ON A SINGLE STACK
16657: # AND CONDENSATIONS ARE MADE WHEN LOW PRECEDENCE OPERATORS
16658: # ARE STACKED AFTER A HIGHER PRECEDENCE OPERATOR. A GLOBAL
16659: # VARIABLE (IN WB) KEEPS TRACK OF THE LEVEL AS FOLLOWS.
16660: #
16661: # 0 SCANNING OUTER LEVEL OF STATEMENT OR EXPRESSION
16662: # 1 SCANNING OUTER LEVEL OF NORMAL GOTO
16663: # 2 SCANNING OUTER LEVEL OF DIRECT GOTO
16664: # 3 SCANNING INSIDE ARRAY BRACKETS
16665: # 4 SCANNING INSIDE GROUPING PARENTHESES
16666: # 5 SCANNING INSIDE FUNCTION PARENTHESES
16667: #
16668: # THIS VARIABLE IS SAVED ON THE STACK ON ENCOUNTERING A
16669: # GROUPING AND RESTORED AT THE END OF THE GROUPING.
16670: #
16671: # ANOTHER GLOBAL VARIABLE (IN WC) COUNTS THE NUMBER OF
16672: # ITEMS AT ONE GROUPING LEVEL AND IS INCREMENTED FOR EACH
16673: # COMMA ENCOUNTERED. IT IS STACKED WITH THE LEVEL INDICATOR
16674: #
16675: # THE SCAN IS CONTROLLED BY A THREE STATE FINITE MACHINE.
16676: # A GLOBAL VARIABLE STORED IN WA IS THE CURRENT STATE.
16677: #
16678: # WA=0 NOTHING SCANNED AT THIS LEVEL
16679: # WA=1 OPERAND EXPECTED
16680: # WA=2 OPERATOR EXPECTED
16681: #
16682: # (WB) CALL TYPE (SEE BELOW)
16683: # JSR EXPAN CALL TO ANALYZE EXPRESSION
16684: # (XR) POINTER TO RESULTING TREE
16685: # (XL,WA,WB,WC,RA) DESTROYED
16686: #
16687: # THE ENTRY VALUE OF WB INDICATES THE CALL TYPE AS FOLLOWS.
16688: #
16689: # 0 SCANNING EITHER THE MAIN BODY OF A STATEMENT OR THE
16690: # TEXT OF AN EXPRESSION (FROM EVAL CALL). VALID
16691: # TERMINATORS ARE COLON, SEMICOLON. THE RESCAN FLAG IS
16692: # SET TO RETURN THE TERMINATOR ON THE NEXT SCANE CALL.
16693: #
16694: # 1 SCANNING A NORMAL GOTO. THE ONLY VALID
16695: # TERMINATOR IS A RIGHT PAREN.
16696: #
16697: # 2 SCANNING A DIRECT GOTO. THE ONLY VALID
16698: # TERMINATOR IS A RIGHT BRACKET.
16699: #page
16700: #
16701: # EXPAN (CONTINUED)
16702: #
16703: # ENTRY POINT
16704: #
16705: expan: #prc # entry point
16706: clrl -(sp) # set top of stack indicator
16707: clrl r6 # set initial state to zero
16708: clrl r8 # zero counter value
16709: #
16710: # LOOP HERE FOR SUCCESSIVE ENTRIES
16711: #
16712: exp01: jsb scane # scan next element
16713: addl2 r6,r10 # add state to syntax code
16714: casel r10,$0,$t$nes # switch on element type/state
16715: 5:
16716: .word exp27-5b # unop, s=0
16717: .word exp27-5b # unop, s=1
16718: .word exp04-5b # unop, s=2
16719: .word exp06-5b # left paren, s=0
16720: .word exp06-5b # left paren, s=1
16721: .word exp04-5b # left paren, s=2
16722: .word exp08-5b # left brkt, s=0
16723: .word exp08-5b # left brkt, s=1
16724: .word exp09-5b # left brkt, s=2
16725: .word exp02-5b # comma, s=0
16726: .word exp05-5b # comma, s=1
16727: .word exp11-5b # comma, s=2
16728: .word exp10-5b # function, s=0
16729: .word exp10-5b # function, s=1
16730: .word exp04-5b # function, s=2
16731: .word exp03-5b # variable, s=0
16732: .word exp03-5b # variable, state one
16733: .word exp04-5b # variable, s=2
16734: .word exp03-5b # constant, s=0
16735: .word exp03-5b # constant, s=1
16736: .word exp04-5b # constant, s=2
16737: .word exp05-5b # binop, s=0
16738: .word exp05-5b # binop, s=1
16739: .word exp26-5b # binop, s=2
16740: .word exp02-5b # right paren, s=0
16741: .word exp05-5b # right paren, s=1
16742: .word exp12-5b # right paren, s=2
16743: .word exp02-5b # right brkt, s=0
16744: .word exp05-5b # right brkt, s=1
16745: .word exp18-5b # right brkt, s=2
16746: .word exp02-5b # colon, s=0
16747: .word exp05-5b # colon, s=1
16748: .word exp19-5b # colon, s=2
16749: .word exp02-5b # semicolon, s=0
16750: .word exp05-5b # semicolon, s=1
16751: .word exp19-5b # semicolon, s=2
16752: #esw # end switch on element type/state
16753: #page
16754: #
16755: # EXPAN (CONTINUED)
16756: #
16757: # HERE FOR RBR,RPR,COL,SMC,CMA IN STATE 0
16758: #
16759: # SET TO RESCAN THE TERMINATOR ENCOUNTERED AND CREATE
16760: # A NULL CONSTANT (CASE OF OMITTED NULL)
16761: #
16762: exp02: movl sp,scnrs # set to rescan element
16763: movl $nulls,r9 # point to null, merge
16764: #
16765: # HERE FOR VAR OR CON IN STATES 0,1
16766: #
16767: # STACK THE VARIABLE/CONSTANT AND SET STATE=2
16768: #
16769: exp03: movl r9,-(sp) # stack pointer to operand
16770: movl $num02,r6 # set state 2
16771: jmp exp01 # jump for next element
16772: #
16773: # HERE FOR VAR,CON,LPR,FNC,UOP IN STATE 2
16774: #
16775: # WE RESCAN THE ELEMENT AND CREATE A CONCATENATION OPERATOR
16776: # THIS IS THE CASE OF THE BLANK CONCATENATION OPERATOR.
16777: #
16778: exp04: movl sp,scnrs # set to rescan element
16779: movl $opdvc,r9 # point to concat operator dv
16780: tstl r7 # ok if at top level
16781: beqlu exp4a
16782: movl $opdvp,r9 # else point to unmistakable concat.
16783: #
16784: # MERGE HERE WHEN XR SET UP WITH PROPER CONCATENATION DVBLK
16785: #
16786: exp4a: tstl scnbl # merge bop if blanks, else error
16787: beqlu 0f
16788: jmp exp26
16789: 0:
16790: decl scnse # adjust start of element location
16791: jmp er_220 # syntax error. missing operator
16792: #
16793: # HERE FOR CMA,RPR,RBR,COL,SMC,BOP(S=1) BOP(S=0)
16794: #
16795: # THIS IS AN ERRONOUS CONTRUCTION
16796: #
16797: exp05: decl scnse # adjust start of element location
16798: jmp er_221 # syntax error. missing operand
16799: #
16800: # HERE FOR LPR (S=0,1)
16801: #
16802: exp06: movl $num04,r10 # set new level indicator
16803: clrl r9 # set zero value for cmopn
16804: #page
16805: #
16806: # EXPAN (CONTINUED)
16807: #
16808: # MERGE HERE TO STORE OLD LEVEL ON STACK AND START NEW ONE
16809: #
16810: exp07: movl r9,-(sp) # stack cmopn value
16811: movl r8,-(sp) # stack old counter
16812: movl r7,-(sp) # stack old level indicator
16813: jsb sbchk # check for stack overflow
16814: clrl r6 # set new state to zero
16815: movl r10,r7 # set new level indicator
16816: movl $num01,r8 # initialize new counter
16817: jmp exp01 # jump to scan next element
16818: #
16819: # HERE FOR LBR (S=0,1)
16820: #
16821: # THIS IS AN ILLEGAL USE OF LEFT BRACKET
16822: #
16823: exp08: jmp er_222 # syntax error. invalid use of left bracket
16824: #
16825: # HERE FOR LBR (S=2)
16826: #
16827: # SET NEW LEVEL AND START TO SCAN SUBSCRIPTS
16828: #
16829: exp09: movl (sp)+,r9 # load array ptr for cmopn
16830: movl $num03,r10 # set new level indicator
16831: jmp exp07 # jump to stack old and start new
16832: #
16833: # HERE FOR FNC (S=0,1)
16834: #
16835: # STACK OLD LEVEL AND START TO SCAN ARGUMENTS
16836: #
16837: exp10: movl $num05,r10 # set new lev indic (xr=vrblk=cmopn)
16838: jmp exp07 # jump to stack old and start new
16839: #
16840: # HERE FOR CMA (S=2)
16841: #
16842: # INCREMENT ARGUMENT COUNT AND CONTINUE
16843: #
16844: exp11: incl r8 # increment counter
16845: jsb expdm # dump operators at this level
16846: clrl -(sp) # set new level for parameter
16847: clrl r6 # set new state
16848: cmpl r7,$num02 # loop back unless outer level
16849: blequ 0f
16850: jmp exp01
16851: 0:
16852: jmp er_223 # syntax error. invalid use of comma
16853: #page
16854: #
16855: # EXPAN (CONTINUED)
16856: #
16857: # HERE FOR RPR (S=2)
16858: #
16859: # AT OUTER LEVEL IN A NORMAL GOTO THIS IS A TERMINATOR
16860: # OTHERWISE IT MUST TERMINATE A FUNCTION OR GROUPING
16861: #
16862: exp12: cmpl r7,$num01 # end of normal goto
16863: bnequ 0f
16864: jmp exp20
16865: 0:
16866: cmpl r7,$num05 # end of function arguments
16867: beqlu exp13
16868: cmpl r7,$num04 # end of grouping / selection
16869: beqlu exp14
16870: jmp er_224 # syntax error. unbalanced right parenthesis
16871: #
16872: # HERE AT END OF FUNCTION ARGUMENTS
16873: #
16874: exp13: movl $c$fnc,r10 # set cmtyp value for function
16875: jmp exp15 # jump to build cmblk
16876: #
16877: # HERE FOR END OF GROUPING
16878: #
16879: exp14: cmpl r8,$num01 # jump if end of grouping
16880: beqlu exp17
16881: movl $c$sel,r10 # else set cmtyp for selection
16882: #
16883: # MERGE HERE TO BUILD CMBLK FOR LEVEL JUST SCANNED AND
16884: # TO POP UP TO THE PREVIOUS SCAN LEVEL BEFORE CONTINUING.
16885: #
16886: exp15: jsb expdm # dump operators at this level
16887: movl r8,r6 # copy count
16888: addl2 $cmvls,r6 # add for standard fields at start
16889: moval 0[r6],r6 # convert length to bytes
16890: jsb alloc # allocate space for cmblk
16891: movl $b$cmt,(r9) # store type code for cmblk
16892: movl r10,4*cmtyp(r9) # store cmblk node type indicator
16893: movl r6,4*cmlen(r9) # store length
16894: addl2 r6,r9 # point past end of block
16895: # set loop counter
16896: #
16897: # LOOP TO MOVE REMAINING WORDS TO CMBLK
16898: #
16899: exp16: movl (sp)+,-(r9) # move one operand ptr from stack
16900: movl (sp)+,r7 # pop to old level indicator
16901: sobgtr r8,exp16 # loop till all moved
16902: #page
16903: #
16904: # EXPAN (CONTINUED)
16905: #
16906: # COMPLETE CMBLK AND STACK POINTER TO IT ON STACK
16907: #
16908: subl2 $4*cmvls,r9 # point back to start of block
16909: movl (sp)+,r8 # restore old counter
16910: movl (sp),4*cmopn(r9)# store operand ptr in cmblk
16911: movl r9,(sp) # stack cmblk pointer
16912: movl $num02,r6 # set new state
16913: jmp exp01 # back for next element
16914: #
16915: # HERE AT END OF A PARENTHESIZED EXPRESSION
16916: #
16917: exp17: jsb expdm # dump operators at this level
16918: movl (sp)+,r9 # restore xr
16919: movl (sp)+,r7 # restore outer level
16920: movl (sp)+,r8 # restore outer count
16921: movl r9,(sp) # store opnd over unused cmopn val
16922: movl $num02,r6 # set new state
16923: jmp exp01 # back for next ele8ent
16924: #
16925: # HERE FOR RBR (S=2)
16926: #
16927: # AT OUTER LEVEL IN A DIRECT GOTO, THIS IS A TERMINATOR.
16928: # OTHERWISE IT MUST TERMINATE A SUBSCRIPT LIST.
16929: #
16930: exp18: movl $c$arr,r10 # set cmtyp for array reference
16931: cmpl r7,$num03 # jump to build cmblk if end arrayref
16932: beqlu exp15
16933: cmpl r7,$num02 # jump if end of direct goto
16934: bnequ 0f
16935: jmp exp20
16936: 0:
16937: jmp er_225 # syntax error. unbalanced right bracket
16938: #page
16939: #
16940: # EXPAN (CONTINUED)
16941: #
16942: # HERE FOR COL,SMC (S=2)
16943: #
16944: # ERROR UNLESS TERMINATING STATEMENT BODY AT OUTER LEVEL
16945: #
16946: exp19: movl sp,scnrs # rescan terminator
16947: movl r7,r10 # copy level indicator
16948: casel r10,$0,$6 # switch on level indicator
16949: 5:
16950: .word exp20-5b # normal outer level
16951: .word exp22-5b # fail if normal goto
16952: .word exp23-5b # fail if direct goto
16953: .word exp24-5b # fail array brackets
16954: .word exp21-5b # fail if in grouping
16955: .word exp21-5b # fail function args
16956: #esw # end switch on level
16957: #
16958: # HERE AT NORMAL END OF EXPRESSION
16959: #
16960: exp20: jsb expdm # dump remaining operators
16961: movl (sp)+,r9 # load tree pointer
16962: addl2 $4,sp # pop off bottom of stack marker
16963: rsb # return to expan caller
16964: #
16965: # MISSING RIGHT PAREN
16966: #
16967: exp21: jmp er_226 # syntax error. missing right paren
16968: #
16969: # MISSING RIGHT PAREN IN GOTO FIELD
16970: #
16971: exp22: jmp er_227 # syntax error. right paren missing from goto
16972: #
16973: # MISSING BRACKET IN GOTO
16974: #
16975: exp23: jmp er_228 # syntax error. right bracket missing from goto
16976: #
16977: # MISSING ARRAY BRACKET
16978: #
16979: exp24: jmp er_229 # syntax error. missing right array bracket
16980: #page
16981: #
16982: # EXPAN (CONTINUED)
16983: #
16984: # LOOP HERE WHEN AN OPERATOR CAUSES AN OPERATOR DUMP
16985: #
16986: exp25: movl r9,expsv
16987: jsb expop # pop one operator
16988: movl expsv,r9 # restore op dv pointer and merge
16989: #
16990: # HERE FOR BOP (S=2)
16991: #
16992: # REMOVE OPERATORS (CONDENSE) FROM STACK UNTIL NO MORE
16993: # LEFT AT THIS LEVEL OR TOP ONE HAS LOWER PRECEDENCE.
16994: # LOOP HERE TILL THIS CONDITION IS MET.
16995: #
16996: exp26: movl 4*1(sp),r10 # load operator dvptr from stack
16997: cmpl r10,$num05 # jump if bottom of stack level
16998: blequ exp27
16999: cmpl 4*dvrpr(r9),4*dvlpr(r10) # else pop if new prec is lo
17000: blssu exp25
17001: #
17002: # HERE FOR UOP (S=0,1)
17003: #
17004: # BINARY OPERATOR MERGES AFTER PRECEDENCE CHECK
17005: #
17006: # THE OPERATOR DV IS STORED ON THE STACK AND THE SCAN
17007: # CONTINUES AFTER SETTING THE SCAN STATE TO ONE.
17008: #
17009: exp27: movl r9,-(sp) # stack operator dvptr on stack
17010: jsb sbchk # check for stack overflow
17011: movl $num01,r6 # set new state
17012: cmpl r9,$opdvs # back for next element unless =
17013: beqlu 0f
17014: jmp exp01
17015: 0:
17016: #
17017: # HERE FOR SPECIAL CASE OF BINARY =. THE SYNTAX ALLOWS A
17018: # NULL RIGHT ARGUMENT FOR THIS OPERATOR TO BE LEFT
17019: # OUT. ACCORDINGLY WE RESET TO STATE ZERO TO GET PROPER
17020: # ACTION ON A TERMINATOR (SUPPLY A NULL CONSTANT).
17021: #
17022: clrl r6 # set state zero
17023: jmp exp01 # jump for next element
17024: #enp # end procedure expan
17025: #page
17026: #
17027: # EXPAP -- TEST FOR PATTERN MATCH TREE
17028: #
17029: # EXPAP IS PASSED AN EXPRESSION TREE TO DETERMINE IF IT
17030: # IS A PATTERN MATCH. THE FOLLOWING ARE RECOGIZED AS
17031: # MATCHES IN THE CONTEXT OF THIS CALL.
17032: #
17033: # 1) AN EXPLICIT USE OF BINARY QUESTION MARK
17034: # 2) A CONCATENATION
17035: # 3) AN ALTERNATION WHOSE LEFT OPERAND IS A CONCATENATION
17036: #
17037: # (XR) PTR TO EXPAN TREE
17038: # JSR EXPAP CALL TO TEST FOR PATTERN MATCH
17039: # PPM LOC TRANSFER LOC IF NOT A PATTERN MATCH
17040: # (WA) DESTROYED
17041: # (XR) UNCHANGED (IF NOT MATCH)
17042: # (XR) PTR TO BINARY OPERATOR BLK IF MATCH
17043: #
17044: expap: #prc # entry point
17045: movl r10,-(sp) # save xl
17046: cmpl (r9),$b$cmt # no match if not complex
17047: bnequ expp2
17048: movl 4*cmtyp(r9),r6 # else load type code
17049: cmpl r6,$c$cnc # concatenation is a match
17050: beqlu expp1
17051: cmpl r6,$c$pmt # binary question mark is a match
17052: beqlu expp1
17053: cmpl r6,$c$alt # else not match unless alternation
17054: bnequ expp2
17055: #
17056: # HERE FOR ALTERNATION. CHANGE (A B) / C TO A QM (B / C)
17057: #
17058: movl 4*cmlop(r9),r10 # load left operand pointer
17059: cmpl (r10),$b$cmt # not match if left opnd not complex
17060: bnequ expp2
17061: cmpl 4*cmtyp(r10),$c$cnc # not match if left op not conc
17062: bnequ expp2
17063: movl 4*cmrop(r10),4*cmlop(r9) # xr points to (b / c)
17064: movl r9,4*cmrop(r10) # set xl opnds to a, (b / c)
17065: movl r10,r9 # point to this altered node
17066: #
17067: # EXIT HERE FOR PATTERN MATCH
17068: #
17069: expp1: movl (sp)+,r10 # restore entry xl
17070: addl2 $4*1,(sp) # give pattern match return
17071: rsb
17072: #
17073: # EXIT HERE IF NOT PATTERN MATCH
17074: #
17075: expp2: movl (sp)+,r10 # restore entry xl
17076: movl (sp)+,r11 # give non-match return
17077: jmp *(r11)+
17078: #enp # end procedure expap
17079: #page
17080: #
17081: # EXPDM -- DUMP OPERATORS AT CURRENT LEVEL (FOR EXPAN)
17082: #
17083: # EXPDM USES EXPOP TO CONDENSE ALL OPERATORS AT THIS SYNTAX
17084: # LEVEL. THE STACK BOTTOM IS RECOGNIZED FROM THE LEVEL
17085: # VALUE WHICH IS SAVED ON THE TOP OF THE STACK.
17086: #
17087: # JSR EXPDM CALL TO DUMP OPERATORS
17088: # (XS) POPPED AS REQUIRED
17089: # (XR,WA) DESTROYED
17090: #
17091: .data 1
17092: expdm_s: .long 0
17093: .text 0
17094: expdm: movl (sp)+,expdm_s # entry point
17095: movl r10,r$exs # save xl value
17096: #
17097: # LOOP TO DUMP OPERATORS
17098: #
17099: exdm1: cmpl 4*1(sp),$num05 # jump if stack bottom (saved level
17100: blequ exdm2
17101: jsb expop # else pop one operator
17102: jmp exdm1 # and loop back
17103: #
17104: # HERE AFTER POPPING ALL OPERATORS
17105: #
17106: exdm2: movl r$exs,r10 # restore xl
17107: clrl r$exs # release save location
17108: jmp *expdm_s # return to expdm caller
17109: #enp # end procedure expdm
17110: #page
17111: #
17112: # EXPOP-- POP OPERATOR (FOR EXPAN)
17113: #
17114: # EXPOP IS USED BY THE EXPAN ROUTINE TO CONDENSE ONE
17115: # OPERATOR FROM THE TOP OF THE SYNTAX STACK. AN APPROPRIATE
17116: # CMBLK IS BUILT FOR THE OPERATOR (UNARY OR BINARY) AND A
17117: # POINTER TO THIS CMBLK IS STACKED.
17118: #
17119: # EXPOP IS ALSO USED BY SCNGF (GOTO FIELD SCAN) PROCEDURE
17120: #
17121: # JSR EXPOP CALL TO POP OPERATOR
17122: # (XS) POPPED APPROPRIATELY
17123: # (XR,XL,WA) DESTROYED
17124: #
17125: .data 1
17126: expop_s: .long 0
17127: .text 0
17128: expop: movl (sp)+,expop_s # entry point
17129: movl 4*1(sp),r9 # load operator dv pointer
17130: cmpl 4*dvlpr(r9),$lluno # jump if unary
17131: beqlu expo2
17132: #
17133: # HERE FOR BINARY OPERATOR
17134: #
17135: movl $4*cmbs$,r6 # set size of binary operator cmblk
17136: jsb alloc # allocate space for cmblk
17137: movl (sp)+,4*cmrop(r9)# pop and store right operand ptr
17138: movl (sp)+,r10 # pop and load operator dv ptr
17139: movl (sp),4*cmlop(r9)# store left operand pointer
17140: #
17141: # COMMON EXIT POINT
17142: #
17143: expo1: movl $b$cmt,(r9) # store type code for cmblk
17144: movl 4*dvtyp(r10),4*cmtyp(r9) # store cmblk node type code
17145: movl r10,4*cmopn(r9) # store dvptr (=ptr to dac o$xxx)
17146: movl r6,4*cmlen(r9) # store cmblk length
17147: movl r9,(sp) # store resulting node ptr on stack
17148: jmp *expop_s # return to expop caller
17149: #
17150: # HERE FOR UNARY OPERATOR
17151: #
17152: expo2: movl $4*cmus$,r6 # set size of unary operator cmblk
17153: jsb alloc # allocate space for cmblk
17154: movl (sp)+,4*cmrop(r9)# pop and store operand pointer
17155: movl (sp),r10 # load operator dv pointer
17156: jmp expo1 # merge back to exit
17157: #enp # end procedure expop
17158: #page
17159: #
17160: # FLSTG -- FOLD STRING TO UPPER CASE
17161: #
17162: # FLSTG FOLDS A CHARACTER STRING CONTAINING LOWER CASE
17163: # CHARACCTERS TO ONE CONTAINING UPPER CASE CHARACTERS.
17164: # FOLDING IS ONLY DONE IF &CASE (KVCAS) IS NOT ZERO.
17165: #
17166: # (XR) STRING ARGUMENT
17167: # (WA) LENGTH OF STRING
17168: # JSR FLSTG CALL TO FOLD STRING
17169: # (XR) RESULT STRING (POSSIBLY ORIGINAL)
17170: # (WC) DESTROYED
17171: #
17172: flstg: #prc # entry point
17173: tstl kvcas # skip if &case is 0
17174: beqlu fst99
17175: movl r10,-(sp) # save xl across call
17176: movl r9,-(sp) # save original scblk ptr
17177: jsb alocs # allocate new string block
17178: movl (sp),r10 # point to original scblk
17179: movl r9,-(sp) # save pointer to new scblk
17180: movab cfp$f(r10),r10 # point to original chars
17181: movab cfp$f(r9),r9 # point to new chars
17182: clrl -(sp) # init did fold flag
17183: # load loop counter
17184: fst01: movzbl (r10)+,r6 # load character
17185: cmpl $ch$$a,r6 # skip if less than lc a
17186: bgtru fst02
17187: cmpl r6,$ch$$$ # skip if greater than lc z
17188: bgtru fst02
17189: bicl2 $ch$bl,r6 # fold character to upper case
17190: movl sp,(sp) # set did fold character flag
17191: fst02: movb r6,(r9)+ # store (possibly folded) character
17192: sobgtr r8,fst01 # loop thru entire string
17193: #csc r9 # complete store characters
17194: tstl (sp)+ # skip if folding done
17195: bnequ fst10
17196: movl (sp)+,dnamp # do not need new scblk
17197: movl (sp)+,r9 # return original scblk
17198: jmp fst20 # merge below
17199: fst10: movl (sp)+,r9 # return new scblk
17200: addl2 $4,sp # throw away original scblk pointer
17201: fst20: movl 4*sclen(r9),r6 # reload string length
17202: movl (sp)+,r10 # restore xl
17203: fst99: rsb # return
17204: #enp
17205: #page
17206: #
17207: # GBCOL -- PERFORM GARBAGE COLLECTION
17208: #
17209: # GBCOL PERFORMS A GARBAGE COLLECTION ON THE DYNAMIC REGION
17210: # ALL BLOCKS WHICH ARE NO LONGER IN USE ARE ELIMINATED
17211: # BY MOVING BLOCKS WHICH ARE IN USE DOWN AND RESETTING
17212: # DNAMP, THE POINTER TO THE NEXT AVAILABLE LOCATION.
17213: #
17214: # (WB) MOVE OFFSET (SEE BELOW)
17215: # JSR GBCOL CALL TO COLLECT GARBAGE
17216: # (XR) DESTROYED
17217: #
17218: # THE FOLLOWING CONDITIONS MUST BE MET AT THE TIME WHEN
17219: # GBCOL IS CALLED.
17220: #
17221: # 1) ALL POINTERS TO BLOCKS IN THE DYNAMIC AREA MUST BE
17222: # ACCESSIBLE TO THE GARBAGE COLLECTOR. THIS MEANS
17223: # THAT THEY MUST OCCUR IN ONE OF THE FOLLOWING.
17224: #
17225: # A) MAIN STACK, WITH CURRENT TOP
17226: # ELEMENT BEING INDICATED BY XS
17227: #
17228: # B) IN RELOCATABLE FIELDS OF VRBLKS.
17229: #
17230: # C) IN REGISTER XL AT THE TIME OF CALL
17231: #
17232: # E) IN THE SPECIAL REGION OF WORKING
17233: # STORAGE WHERE NAMES BEGIN WITH R$.
17234: #
17235: # 2) ALL POINTERS MUST POINT TO THE START OF BLOCKS WITH
17236: # THE SOLE EXCEPTION OF THE CONTENTS OF THE CODE
17237: # POINTER REGISTER WHICH POINTS INTO THE R$COD BLOCK.
17238: #
17239: # 3) NO LOCATION WHICH APPEARS TO CONTAIN A POINTER
17240: # INTO THE DYNAMIC REGION MAY OCCUR UNLESS IT IS IN
17241: # FACT A POINTER TO THE START OF THE BLOCK. HOWEVER
17242: # POINTERS OUTSIDE THIS AREA MAY OCCUR AND WILL
17243: # NOT BE CHANGED BY THE GARBAGE COLLECTOR.
17244: # IT IS ESPECIALLY IMPORTANT TO MAKE SURE THAT XL
17245: # DOES NOT CONTAIN A GARBAGE VALUE FROM SOME PROCESS
17246: # CARRIED OUT BEFORE THE CALL TO THE COLLECTOR.
17247: #
17248: # GBCOL HAS THE CAPABILITY OF MOVING THE FINAL COMPACTED
17249: # RESULT UP IN MEMORY (WITH ADDRESSES ADJUSTED ACCORDINGLY)
17250: # THIS IS USED TO ADD SPACE TO THE STATIC REGION. THE
17251: # ENTRY VALUE OF WB IS THE NUMBER OF BYTES TO MOVE UP.
17252: # THE CALLER MUST GUARANTEE THAT THERE IS ENOUGH ROOM.
17253: # FURTHERMORE THE VALUE IN WB IF IT IS NON-ZERO, MUST BE AT
17254: # LEAST 256 SO THAT THE MWB INSTRUCTION CONDITIONS ARE MET.
17255: #page
17256: #
17257: # GBCOL (CONTINUED)
17258: #
17259: # THE ALGORITHM, WHICH IS A MODIFICATION OF THE LISP-2
17260: # GARBAGE COLLECTOR DEVISED BY R.DEWAR AND K.BELCHER
17261: # TAKES THREE PASSES AS FOLLOWS.
17262: #
17263: # 1) ALL POINTERS IN MEMORY ARE SCANNED AND BLOCKS IN USE
17264: # DETERMINED FROM THIS SCAN. NOTE THAT THIS PROCEDURE
17265: # IS RECURSIVE AND USES THE MAIN STACK FOR LINKAGE.
17266: # THE MARKING PROCESS IS THUS SIMILAR TO THAT USED IN
17267: # A STANDARD LISP COLLECTOR. HOWEVER THE METHOD OF
17268: # ACTUALLY MARKING THE BLOCKS IS DIFFERENT.
17269: #
17270: # THE FIRST FIELD OF A BLOCK NORMALLY CONTAINS A
17271: # CODE ENTRY POINT POINTER. SUCH AN ENTRY POINTER
17272: # CAN BE DISTINGUISHED FROM THE ADDRESS OF ANY POINTER
17273: # TO BE PROCESSED BY THE COLLECTOR. DURING GARBAGE
17274: # COLLECTION, THIS WORD IS USED TO BUILD A BACK CHAIN
17275: # OF POINTERS THROUGH FIELDS WHICH POINT TO THE BLOCK.
17276: # THE END OF THE CHAIN IS MARKED BY THE OCCURENCE
17277: # OF THE WORD WHICH USED TO BE IN THE FIRST WORD OF
17278: # THE BLOCK. THIS BACKCHAIN SERVES BOTH AS A MARK
17279: # INDICATING THAT THE BLOCK IS IN USE AND AS A LIST OF
17280: # REFERENCES FOR THE RELOCATION PHASE.
17281: #
17282: # 2) STORAGE IS SCANNED SEQUENTIALLY TO DISCOVER WHICH
17283: # BLOCKS ARE CURRENTLY IN USE AS INDICATED BY THE
17284: # PRESENCE OF A BACKCHAIN. TWO POINTERS ARE MAINTAINED
17285: # ONE SCANS THROUGH LOOKING AT EACH BLOCK. THE OTHER
17286: # IS INCREMENTED ONLY FOR BLOCKS FOUND TO BE IN USE.
17287: # IN THIS WAY, THE EVENTUAL LOCATION OF EACH BLOCK CAN
17288: # BE DETERMINED WITHOUT ACTUALLY MOVING ANY BLOCKS.
17289: # AS EACH BLOCK WHICH IS IN USE IS PROCESSED, THE BACK
17290: # CHAIN IS USED TO RESET ALL POINTERS WHICH POINT TO
17291: # THIS BLOCK TO CONTAIN ITS NEW ADDRESS, I.E. THE
17292: # ADDRESS IT WILL OCCUPY AFTER THE BLOCKS ARE MOVED.
17293: # THE FIRST WORD OF THE BLOCK, TAKEN FROM THE END OF
17294: # THE CHAIN IS RESTORED AT THIS POINT.
17295: #
17296: # DURING PASS 2, THE COLLECTOR BUILDS BLOCKS WHICH
17297: # DESCRIBE THE REGIONS OF STORAGE WHICH ARE TO BE
17298: # MOVED IN THE THIRD PASS. THERE IS ONE DESCRIPTOR FOR
17299: # EACH CONTIGUOUS SET OF GOOD BLOCKS. THE DESCRIPTOR
17300: # IS BUILT JUST BEHIND THE BLOCK TO BE MOVED AND
17301: # CONTAINS A POINTER TO THE NEXT BLOCK AND THE NUMBER
17302: # OF WORDS TO BE MOVED.
17303: #
17304: # 3) IN THE THIRD AND FINAL PASS, THE MOVE DESCRIPTOR
17305: # BLOCKS BUILT IN PASS TWO ARE USED TO ACTUALLY MOVE
17306: # THE BLOCKS DOWN TO THE BOTTOM OF THE DYNAMIC REGION.
17307: # THE COLLECTION IS THEN COMPLETE AND THE NEXT
17308: # AVAILABLE LOCATION POINTER IS RESET.
17309: #page
17310: #
17311: # GBCOL (CONTINUED)
17312: #
17313: gbcol: #prc # entry point
17314: tstl dmvch # fail if in mid-dump
17315: beqlu 0f
17316: jmp gbc14
17317: 0:
17318: movl sp,gbcfl # note gbcol entered
17319: movl r6,gbsva # save entry wa
17320: movl r7,gbsvb # save entry wb
17321: movl r8,gbsvc # save entry wc
17322: movl r10,-(sp) # save entry xl
17323: movl r3,r6 # get code pointer value
17324: subl2 r$cod,r6 # make relative
17325: movl r6,r3 # and restore
17326: #
17327: # PROCESS STACK ENTRIES
17328: #
17329: movl sp,r9 # point to stack front
17330: movl stbas,r10 # point past end of stack
17331: cmpl r10,r9 # ok if d-stack
17332: bgequ gbc00
17333: movl r10,r9 # reverse if ...
17334: movl sp,r10 # ... u-stack
17335: #
17336: # PROCESS THE STACK
17337: #
17338: gbc00: jsb gbcpf # process pointers on stack
17339: #
17340: # PROCESS SPECIAL WORK LOCATIONS
17341: #
17342: movl $r$aaa,r9 # point to start of relocatable locs
17343: movl $r$yyy,r10 # point past end of relocatable locs
17344: jsb gbcpf # process work fields
17345: #
17346: # PREPARE TO PROCESS VARIABLE BLOCKS
17347: #
17348: movl hshtb,r6 # point to first hash slot pointer
17349: #
17350: # LOOP THROUGH HASH SLOTS
17351: #
17352: gbc01: movl r6,r10 # point to next slot
17353: addl2 $4,r6 # bump bucket pointer
17354: movl r6,gbcnm # save bucket pointer
17355: #page
17356: #
17357: # GBCOL (CONTINUED)
17358: #
17359: # LOOP THROUGH VARIABLES ON ONE HASH CHAIN
17360: #
17361: gbc02: movl (r10),r9 # load ptr to next vrblk
17362: beqlu gbc03 # jump if end of chain
17363: movl r9,r10 # else copy vrblk pointer
17364: addl2 $4*vrval,r9 # point to first reloc fld
17365: addl2 $4*vrnxt,r10 # point past last (and to link ptr)
17366: jsb gbcpf # process reloc fields in vrblk
17367: jmp gbc02 # loop back for next block
17368: #
17369: # HERE AT END OF ONE HASH CHAIN
17370: #
17371: gbc03: movl gbcnm,r6 # restore bucket pointer
17372: cmpl r6,hshte # loop back if more buckets to go
17373: bnequ gbc01
17374: #page
17375: #
17376: # GBCOL (CONTINUED)
17377: #
17378: # NOW WE ARE READY TO START PASS TWO. REGISTERS ARE USED
17379: # AS FOLLOWS IN PASS TWO.
17380: #
17381: # (XR) SCANS THROUGH ALL BLOCKS
17382: # (WC) POINTER TO EVENTUAL LOCATION
17383: #
17384: # THE MOVE DESCRIPTION BLOCKS BUILT IN THIS PASS HAVE
17385: # THE FOLLOWING FORMAT.
17386: #
17387: # WORD 1 POINTER TO NEXT MOVE BLOCK,
17388: # ZERO IF END OF CHAIN OF BLOCKS
17389: #
17390: # WORD 2 LENGTH OF BLOCKS TO BE MOVED IN
17391: # BYTES. SET TO THE ADDRESS OF THE
17392: # FIRST BYTE WHILE ACTUALLY SCANNING
17393: # THE BLOCKS.
17394: #
17395: # THE FIRST ENTRY ON THIS CHAIN IS A SPECIAL ENTRY
17396: # CONSISTING OF THE TWO WORDS GBCNM AND GBCNS. AFTER
17397: # BUILDING THE CHAIN OF MOVE DESCRIPTORS, GBCNM POINTS TO
17398: # THE FIRST REAL MOVE BLOCK, AND GBCNS IS THE LENGTH OF
17399: # BLOCKS IN USE AT THE START OF STORAGE WHICH NEED NOT
17400: # BE MOVED SINCE THEY ARE IN THE CORRECT POSITION.
17401: #
17402: gbc04: movl dnamb,r9 # point to first block
17403: movl r9,r8 # set as first eventual location
17404: addl2 gbsvb,r8 # add offset for eventual move up
17405: clrl gbcnm # clear initial forward pointer
17406: movl $gbcnm,gbclm # initialize ptr to last move block
17407: movl r9,gbcns # initialize first address
17408: #
17409: # LOOP THROUGH A SERIES OF BLOCKS IN USE
17410: #
17411: gbc05: cmpl r9,dnamp # jump if end of used region
17412: beqlu gbc07
17413: movl (r9),r6 # else get first word
17414: cmpl r6,$p$yyy # skip if not entry ptr (in use)
17415: bgequ gbc06
17416: cmpl r6,$b$aaa # jump if entry pointer (unused)
17417: bgequ gbc07
17418: #
17419: # HERE FOR BLOCK IN USE, LOOP TO RELOCATE REFERENCES
17420: #
17421: gbc06: movl r6,r10 # copy pointer
17422: movl (r10),r6 # load forward pointer
17423: movl r8,(r10) # relocate reference
17424: cmpl r6,$p$yyy # loop back if not end of chain
17425: bgequ gbc06
17426: cmpl r6,$b$aaa # loop back if not end of chain
17427: blequ gbc06
17428: #page
17429: #
17430: # GBCOL (CONTINUED)
17431: #
17432: # AT END OF CHAIN, RESTORE FIRST WORD AND BUMP PAST
17433: #
17434: movl r6,(r9) # restore first word
17435: jsb blkln # get length of this block
17436: addl2 r6,r9 # bump actual pointer
17437: addl2 r6,r8 # bump eventual pointer
17438: jmp gbc05 # loop back for next block
17439: #
17440: # HERE AT END OF A SERIES OF BLOCKS IN USE
17441: #
17442: gbc07: movl r9,r6 # copy pointer past last block
17443: movl gbclm,r10 # point to previous move block
17444: subl2 4*1(r10),r6 # subtract starting address
17445: movl r6,4*1(r10) # store length of block to be moved
17446: #
17447: # LOOP THROUGH A SERIES OF BLOCKS NOT IN USE
17448: #
17449: gbc08: cmpl r9,dnamp # jump if end of used region
17450: beqlu gbc10
17451: movl (r9),r6 # else load first word of next block
17452: cmpl r6,$p$yyy # jump if in use
17453: bgequ gbc09
17454: cmpl r6,$b$aaa # jump if in use
17455: blequ gbc09
17456: jsb blkln # else get length of next block
17457: addl2 r6,r9 # push pointer
17458: jmp gbc08 # and loop back
17459: #
17460: # HERE FOR A BLOCK IN USE AFTER PROCESSING A SERIES OF
17461: # BLOCKS WHICH WERE NOT IN USE, BUILD NEW MOVE BLOCK.
17462: #
17463: gbc09: subl2 $4*num02,r9 # point 2 words behind for move block
17464: movl gbclm,r10 # point to previous move block
17465: movl r9,(r10) # set forward ptr in previous block
17466: clrl (r9) # zero forward ptr of new block
17467: movl r9,gbclm # remember address of this block
17468: movl r9,r10 # copy ptr to move block
17469: addl2 $4*num02,r9 # point back to block in use
17470: movl r9,4*1(r10) # store starting address
17471: jmp gbc06 # jump to process block in use
17472: #page
17473: #
17474: # GBCOL (CONTINUED)
17475: #
17476: # HERE FOR PASS THREE -- ACTUALLY MOVE THE BLOCKS DOWN
17477: #
17478: # (XL) POINTER TO OLD LOCATION
17479: # (XR) POINTER TO NEW LOCATION
17480: #
17481: gbc10: movl dnamb,r9 # point to start of storage
17482: addl2 gbcns,r9 # bump past unmoved blocks at start
17483: #
17484: # LOOP THROUGH MOVE DESCRIPTORS
17485: #
17486: gbc11: movl gbcnm,r10 # point to next move block
17487: beqlu gbc12 # jump if end of chain
17488: movl (r10)+,gbcnm # move pointer down chain
17489: movl (r10)+,r6 # get length to move
17490: jsb sbmvw # perform move
17491: jmp gbc11 # loop back
17492: #
17493: # NOW TEST FOR MOVE UP
17494: #
17495: gbc12: movl r9,dnamp # set next available loc ptr
17496: movl gbsvb,r7 # reload move offset
17497: beqlu gbc13 # jump if no move required
17498: movl r9,r10 # else copy old top of core
17499: addl2 r7,r9 # point to new top of core
17500: movl r9,dnamp # save new top of core pointer
17501: movl r10,r6 # copy old top
17502: subl2 dnamb,r6 # minus old bottom = length
17503: addl2 r7,dnamb # bump bottom to get new value
17504: jsb sbmwb # perform move (backwards)
17505: #
17506: # MERGE HERE TO EXIT
17507: #
17508: gbc13: movl gbsva,r6 # restore wa
17509: movl r3,r8 # get code pointer
17510: addl2 r$cod,r8 # make absolute again
17511: movl r8,r3 # and replace absolute value
17512: movl gbsvc,r8 # restore wc
17513: movl (sp)+,r10 # restore entry xl
17514: incl gbcnt # increment count of collections
17515: clrl r9 # clear garbage value in xr
17516: clrl gbcfl # note exit from gbcol
17517: rsb # exit to gbcol caller
17518: #
17519: # GARBAGE COLLECTION NOT ALLOWED WHILST DUMPING
17520: #
17521: gbc14: incl errft # fatal error
17522: jmp er_250 # insufficient memory to complete dump
17523: #enp # end procedure gbcol
17524: #page
17525: #
17526: # GBCPF -- PROCESS FIELDS FOR GARBAGE COLLECTOR
17527: #
17528: # THIS PROCEDURE IS USED BY THE GARBAGE COLLECTOR TO
17529: # PROCESS FIELDS IN PASS ONE. SEE GBCOL FOR FULL DETAILS.
17530: #
17531: # (XR) PTR TO FIRST LOCATION TO PROCESS
17532: # (XL) PTR PAST LAST LOCATION TO PROCESS
17533: # JSR GBCPF CALL TO PROCESS FIELDS
17534: # (XR,WA,WB,WC,IA) DESTROYED
17535: #
17536: # NOTE THAT ALTHOUGH THIS PROCEDURE USES A RECURSIVE
17537: # APPROACH, IT CONTROLS ITS OWN STACK AND IS NOT RECURSIVE.
17538: #
17539: gbcpf: #prc # entry point
17540: clrl -(sp) # set zero to mark bottom of stack
17541: movl r10,-(sp) # save end pointer
17542: #
17543: # MERGE HERE TO GO DOWN A LEVEL AND START A NEW LOOP
17544: #
17545: # 1(XS) NEXT LVL FIELD PTR (0 AT OUTER LVL)
17546: # 0(XS) PTR PAST LAST FIELD TO PROCESS
17547: # (XR) PTR TO FIRST FIELD TO PROCESS
17548: #
17549: # LOOP TO PROCESS SUCCESSIVE FIELDS
17550: #
17551: gpf01: movl (r9),r10 # load field contents
17552: movl r9,r8 # save field pointer
17553: cmpl r10,dnamb # jump if not ptr into dynamic area
17554: blssu gpf02
17555: cmpl r10,dnamp # jump if not ptr into dynamic area
17556: bgequ gpf02
17557: #
17558: # HERE WE HAVE A PTR TO A BLOCK IN THE DYNAMIC AREA.
17559: # LINK THIS FIELD ONTO THE REFERENCE BACKCHAIN.
17560: #
17561: movl (r10),r6 # load ptr to chain (or entry ptr)
17562: movl r9,(r10) # set this field as new head of chain
17563: movl r6,(r9) # set forward pointer
17564: #
17565: # NOW SEE IF THIS BLOCK HAS BEEN PROCESSED BEFORE
17566: #
17567: cmpl r6,$p$yyy # jump if already processed
17568: bgequ gpf02
17569: cmpl r6,$b$aaa # jump if not already processed
17570: bgequ gpf03
17571: #
17572: # HERE TO MOVE TO NEXT FIELD
17573: #
17574: gpf02: movl r8,r9 # restore field pointer
17575: addl2 $4,r9 # bump to next field
17576: cmpl r9,(sp) # loop back if more to go
17577: bnequ gpf01
17578: #page
17579: #
17580: # GBCPF (CONTINUED)
17581: #
17582: # HERE WE POP UP A LEVEL AFTER FINISHING A BLOCK
17583: #
17584: movl (sp)+,r10 # restore pointer past end
17585: movl (sp)+,r8 # restore block pointer
17586: bnequ gpf02 # continue loop unless outer levl
17587: rsb # return to caller if outer level
17588: #
17589: # HERE TO PROCESS AN ACTIVE BLOCK WHICH HAS NOT BEEN DONE
17590: #
17591: gpf03: movl r10,r9 # copy block pointer
17592: movl r6,r10 # copy first word of block
17593: movzwl -2(r10),r10 # load entry point id (bl$xx)
17594: #
17595: # BLOCK TYPE SWITCH. NOTE THAT BLOCKS WITH NO RELOCATABLE
17596: # FIELDS JUST RETURN TO GPF02 HERE TO CONTINE TO NEXT FLD.
17597: #
17598: casel r10,$0,$bl$$$ # switch on block type
17599: 5:
17600: .word gpf06-5b # arblk
17601: .word gpf18-5b # bcblk
17602: .word gpf08-5b # cdblk
17603: .word gpf17-5b # exblk
17604: .word gpf02-5b # icblk
17605: .word gpf10-5b # nmblk
17606: .word gpf10-5b # p0blk
17607: .word gpf12-5b # p1blk
17608: .word gpf12-5b # p2blk
17609: .word gpf02-5b # rcblk
17610: .word gpf02-5b # scblk
17611: .word gpf02-5b # seblk
17612: .word gpf08-5b # tbblk
17613: .word gpf08-5b # vcblk
17614: .word gpf02-5b # xnblk
17615: .word gpf09-5b # xrblk
17616: .word gpf13-5b # pdblk
17617: .word gpf16-5b # trblk
17618: .word gpf02-5b # bfblk
17619: .word gpf07-5b # ccblk
17620: .word gpf04-5b # cmblk
17621: .word gpf02-5b # ctblk
17622: .word gpf02-5b # dfblk
17623: .word gpf02-5b # efblk
17624: .word gpf10-5b # evblk
17625: .word gpf11-5b # ffblk
17626: .word gpf02-5b # kvblk
17627: .word gpf14-5b # pfblk
17628: .word gpf15-5b # teblk
17629: #esw # end of jump table
17630: #page
17631: #
17632: # GBCPF (CONTINUED)
17633: #
17634: # CMBLK
17635: #
17636: gpf04: movl 4*cmlen(r9),r6 # load length
17637: movl $4*cmtyp,r7 # set offset
17638: #
17639: # HERE TO PUSH DOWN TO NEW LEVEL
17640: #
17641: # (WC) FIELD PTR AT PREVIOUS LEVEL
17642: # (XR) PTR TO NEW BLOCK
17643: # (WA) LENGTH (RELOC FLDS + FLDS AT START)
17644: # (WB) OFFSET TO FIRST RELOC FIELD
17645: #
17646: gpf05: addl2 r9,r6 # point past last reloc field
17647: addl2 r7,r9 # point to first reloc field
17648: movl r8,-(sp) # stack old field pointer
17649: movl r6,-(sp) # stack new limit pointer
17650: jsb sbchk # check for stack overflow
17651: jmp gpf01 # if ok, back to process
17652: #
17653: # ARBLK
17654: #
17655: gpf06: movl 4*arlen(r9),r6 # load length
17656: movl 4*arofs(r9),r7 # set offset to 1st reloc fld (arpro)
17657: jmp gpf05 # all set
17658: #
17659: # CCBLK
17660: #
17661: gpf07: movl 4*ccuse(r9),r6 # set length in use
17662: movl $4*ccuse,r7 # 1st word (make sure at least one)
17663: jmp gpf05 # all set
17664: #page
17665: #
17666: # GBCPF (CONTINUED)
17667: #
17668: # CDBLK, TBBLK, VCBLK
17669: #
17670: gpf08: movl 4*offs2(r9),r6 # load length
17671: movl $4*offs3,r7 # set offset
17672: jmp gpf05 # jump back
17673: #
17674: # XRBLK
17675: #
17676: gpf09: movl 4*xrlen(r9),r6 # load length
17677: movl $4*xrptr,r7 # set offset
17678: jmp gpf05 # jump back
17679: #
17680: # EVBLK, NMBLK, P0BLK
17681: #
17682: gpf10: movl $4*offs2,r6 # point past second field
17683: movl $4*offs1,r7 # offset is one (only reloc fld is 2)
17684: jmp gpf05 # all set
17685: #
17686: # FFBLK
17687: #
17688: gpf11: movl $4*ffofs,r6 # set length
17689: movl $4*ffnxt,r7 # set offset
17690: jmp gpf05 # all set
17691: #
17692: # P1BLK, P2BLK
17693: #
17694: gpf12: movl $4*parm2,r6 # length (parm2 is non-relocatable)
17695: movl $4*pthen,r7 # set offset
17696: jmp gpf05 # all set
17697: #page
17698: #
17699: # GBCPF (CONTINUED)
17700: #
17701: # PDBLK
17702: #
17703: gpf13: movl 4*pddfp(r9),r10 # load ptr to dfblk
17704: movl 4*dfpdl(r10),r6 # get pdblk length
17705: movl $4*pdfld,r7 # set offset
17706: jmp gpf05 # all set
17707: #
17708: # PFBLK
17709: #
17710: gpf14: movl $4*pfarg,r6 # length past last reloc
17711: movl $4*pfcod,r7 # offset to first reloc
17712: jmp gpf05 # all set
17713: #
17714: # TEBLK
17715: #
17716: gpf15: movl $4*tesi$,r6 # set length
17717: movl $4*tesub,r7 # and offset
17718: jmp gpf05 # all set
17719: #
17720: # TRBLK
17721: #
17722: gpf16: movl $4*trsi$,r6 # set length
17723: movl $4*trval,r7 # and offset
17724: jmp gpf05 # all set
17725: #
17726: # EXBLK
17727: #
17728: gpf17: movl 4*exlen(r9),r6 # load length
17729: movl $4*exflc,r7 # set offset
17730: jmp gpf05 # jump back
17731: #
17732: # BCBLK
17733: #
17734: gpf18: movl $4*bcsi$,r6 # set length
17735: movl $4*bcbuf,r7 # and offset
17736: jmp gpf05 # all set
17737: #enp # end procedure gbcpf
17738: #page
17739: #
17740: # GTARR -- GET ARRAY
17741: #
17742: # GTARR IS PASSED AN OBJECT AND RETURNS AN ARRAY IF POSSIBL
17743: #
17744: # (XR) VALUE TO BE CONVERTED
17745: # JSR GTARR CALL TO GET ARRAY
17746: # PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
17747: # (XR) RESULTING ARRAY
17748: # (XL,WA,WB,WC) DESTROYED
17749: #
17750: gtarr: #prc # entry point
17751: movl (r9),r6 # load type word
17752: cmpl r6,$b$art # exit if already an array
17753: bnequ 0f
17754: jmp gtar8
17755: 0:
17756: cmpl r6,$b$vct # exit if already an array
17757: bnequ 0f
17758: jmp gtar8
17759: 0:
17760: cmpl r6,$b$tbt # else fail if not a table (sgd02)
17761: beqlu 0f
17762: jmp gta9a
17763: 0:
17764: #
17765: # HERE WE CONVERT A TABLE TO AN ARRAY
17766: #
17767: movl r9,-(sp) # replace tbblk pointer on stack
17768: clrl r9 # signal first pass
17769: clrl r7 # zero non-null element count
17770: #
17771: # THE FOLLOWING CODE IS EXECUTED TWICE. ON THE FIRST PASS,
17772: # SIGNALLED BY XR=0, THE NUMBER OF NON-NULL ELEMENTS IN
17773: # THE TABLE IS COUNTED IN WB. IN THE SECOND PASS, WHERE
17774: # XR IS A POINTER INTO THE ARBLK, THE NAME AND VALUE ARE
17775: # ENTERED INTO THE CURRENT ARBLK LOCATION.
17776: #
17777: gtar1: movl (sp),r10 # point to table
17778: addl2 4*tblen(r10),r10# point past last bucket
17779: subl2 $4*tbbuk,r10 # set first bucket offset
17780: movl r10,r6 # copy adjusted pointer
17781: #
17782: # LOOP THROUGH BUCKETS IN TABLE BLOCK
17783: # NEXT THREE LINES OF CODE RELY ON TENXT HAVING A VALUE
17784: # 1 LESS THAN TBBUK.
17785: #
17786: gtar2: movl r6,r10 # copy bucket pointer
17787: subl2 $4,r6 # decrement bucket pointer
17788: #
17789: # LOOP THROUGH TEBLKS ON ONE BUCKET CHAIN
17790: #
17791: gtar3: movl 4*tenxt(r10),r10# point to next teblk
17792: cmpl r10,(sp) # jump if chain end (tbblk ptr)
17793: beqlu gtar6
17794: movl r10,cnvtp # else save teblk pointer
17795: #
17796: # LOOP TO FIND VALUE DOWN TRBLK CHAIN
17797: #
17798: gtar4: movl 4*teval(r10),r10# load value
17799: cmpl (r10),$b$trt # loop till value found
17800: beqlu gtar4
17801: movl r10,r8 # copy value
17802: movl cnvtp,r10 # restore teblk pointer
17803: #page
17804: #
17805: # GTARR (CONTINUED)
17806: #
17807: # NOW CHECK FOR NULL AND TEST CASES
17808: #
17809: cmpl r8,$nulls # loop back to ignore null value
17810: beqlu gtar3
17811: tstl r9 # jump if second pass
17812: bnequ gtar5
17813: incl r7 # for the first pass, bump count
17814: jmp gtar3 # and loop back for next teblk
17815: #
17816: # HERE IN SECOND PASS
17817: #
17818: gtar5: movl 4*tesub(r10),(r9)+ # store subscript name
17819: movl r8,(r9)+ # store value in arblk
17820: jmp gtar3 # loop back for next teblk
17821: #
17822: # HERE AFTER SCANNING TEBLKS ON ONE CHAIN
17823: #
17824: gtar6: cmpl r6,(sp) # loop back if more buckets to go
17825: bnequ gtar2
17826: tstl r9 # else jump if second pass
17827: bnequ gtar7
17828: #
17829: # HERE AFTER COUNTING NON-NULL ELEMENTS
17830: #
17831: tstl r7 # fail if no non-null elements
17832: bnequ 0f
17833: jmp gtar9
17834: 0:
17835: movl r7,r6 # else copy count
17836: addl2 r7,r6 # double (two words/element)
17837: addl2 $arvl2,r6 # add space for standard fields
17838: moval 0[r6],r6 # convert length to bytes
17839: cmpl r6,mxlen # fail if too long for array
17840: blssu 0f
17841: jmp gtar9
17842: 0:
17843: jsb alloc # else allocate space for arblk
17844: movl $b$art,(r9) # store type word
17845: clrl 4*idval(r9) # zero id for the moment
17846: movl r6,4*arlen(r9) # store length
17847: movl $num02,4*arndm(r9) # set dimensions = 2
17848: movl intv1,r5 # get integer one
17849: movl r5,4*arlbd(r9) # store as lbd 1
17850: movl r5,4*arlb2(r9) # store as lbd 2
17851: movl intv2,r5 # load integer two
17852: movl r5,4*ardm2(r9) # store as dim 2
17853: movl r7,r5 # get element count as integer
17854: movl r5,4*ardim(r9) # store as dim 1
17855: clrl 4*arpr2(r9) # zero prototype field for now
17856: movl $4*arpr2,4*arofs(r9) # set offset field (signal pass 2)
17857: movl r9,r7 # save arblk pointer
17858: addl2 $4*arvl2,r9 # point to first element location
17859: jmp gtar1 # jump back to fill in elements
17860: #page
17861: #
17862: # GTARR (CONTINUED)
17863: #
17864: # HERE AFTER FILLING IN ELEMENT VALUES
17865: #
17866: gtar7: movl r7,r9 # restore arblk pointer
17867: movl r7,(sp) # store as result
17868: #
17869: # NOW WE NEED THE ARRAY PROTOTYPE WHICH IS OF THE FORM NN,2
17870: # THIS IS OBTAINED BY BUILDING THE STRING FOR NN02 AND
17871: # CHANGING THE ZERO TO A COMMA BEFORE STORING IT.
17872: #
17873: movl 4*ardim(r9),r5 # get number of elements (nn)
17874: mull2 intvh,r5 # multiply by 100
17875: addl2 intv2,r5 # add 2 (nn02)
17876: jsb icbld # build integer
17877: movl r9,-(sp) # store ptr for gtstg
17878: jsb gtstg # convert to string
17879: .long invalid$ # convert fail is impossible
17880: movl r9,r10 # copy string pointer
17881: movl (sp)+,r9 # reload arblk pointer
17882: movl r10,4*arpr2(r9) # store prototype ptr (nn02)
17883: subl2 $num02,r6 # adjust length to point to zero
17884: movab cfp$f(r10)[r6],r10 # point to zero
17885: movl $ch$cm,r7 # load a comma
17886: movb r7,(r10) # store a comma over the zero
17887: #csc r10 # complete store characters
17888: #
17889: # NORMAL RETURN
17890: #
17891: gtar8: addl2 $4*1,(sp) # return to caller
17892: rsb
17893: #
17894: # NON-CONVERSION RETURN
17895: #
17896: gtar9: movl (sp)+,r9 # restore stack for conv err (sgd02)
17897: #
17898: # MERGE TO TAKE CONVERT ERROR WHEN STACK ADJUSTED OK
17899: #
17900: gta9a: movl (sp)+,r11 # return
17901: jmp *(r11)+
17902: #enp # procedure gtarr
17903: #page
17904: #
17905: # GTCOD -- CONVERT TO CODE
17906: #
17907: # (XR) OBJECT TO BE CONVERTED
17908: # JSR GTCOD CALL TO CONVERT TO CODE
17909: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17910: # (XR) POINTER TO RESULTING CDBLK
17911: # (XL,WA,WB,WC,RA) DESTROYED
17912: #
17913: # IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE-
17914: # EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
17915: # WITHOUT RETURNING TO THIS ROUTINE.
17916: #
17917: gtcod: #prc # entry point
17918: cmpl (r9),$b$cds # jump if already code
17919: beqlu gtcd1
17920: cmpl (r9),$b$cdc # jump if already code
17921: beqlu gtcd1
17922: #
17923: # HERE WE MUST GENERATE A CDBLK BY COMPILATION
17924: #
17925: movl r9,-(sp) # stack argument for gtstg
17926: jsb gtstg # convert argument to string
17927: .long gtcd2 # jump if non-convertible
17928: movl flptr,gtcef # save fail ptr in case of error
17929: movl r$cod,r$gtc # also save code ptr
17930: movl r9,r$cim # else set image pointer
17931: movl r6,scnil # set image length
17932: clrl scnpt # set scan pointer
17933: movl $stgxc,stage # set stage for execute compile
17934: movl cmpsn,lstsn # in case listr called
17935: jsb cmpil # compile string
17936: movl $stgxt,stage # reset stage for execute time
17937: clrl r$cim # clear image
17938: #
17939: # MERGE HERE IF NO CONVERT REQUIRED
17940: #
17941: gtcd1: addl2 $4*1,(sp) # give normal gtcod return
17942: rsb
17943: #
17944: # HERE IF UNCONVERTIBLE
17945: #
17946: gtcd2: movl (sp)+,r11 # give error return
17947: jmp *(r11)+
17948: #enp # end procedure gtcod
17949: #page
17950: #
17951: # GTEXP -- CONVERT TO EXPRESSION
17952: #
17953: # (XR) INPUT VALUE TO BE CONVERTED
17954: # JSR GTEXP CALL TO CONVERT TO EXPRESSION
17955: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
17956: # (XR) POINTER TO RESULT EXBLK OR SEBLK
17957: # (XL,WA,WB,WC,RA) DESTROYED
17958: #
17959: # IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE-
17960: # EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
17961: # WITHOUT RETURNING TO THIS ROUTINE.
17962: #
17963: gtexp: #prc # entry point
17964: cmpl (r9),$b$e$$ # jump if already an expression
17965: bgtru 0f
17966: jmp gtex1
17967: 0:
17968: movl r9,-(sp) # store argument for gtstg
17969: jsb gtstg # convert argument to string
17970: .long gtex2 # jump if unconvertible
17971: #
17972: # CHECK THE LAST CHARACTER OF THE STRING FOR COLON OR
17973: # SEMICOLON. THESE CHARACTERS CAN LEGITIMATELY END AN
17974: # EXPRESSION IN OPEN CODE, SO EXPAN WILL NOT DETECT THEM
17975: # AS ERRORS, BUT THEY ARE INVALID AS TERMINATORS FOR A
17976: # STRING THAT IS BEING CONVERTED TO EXPRESSION FORM.
17977: #
17978: movl r9,r10 # copy input string pointer (reg06)
17979: movab cfp$f(r10)[r6],r10 # point one past the string end (reg06)
17980: movzbl -(r10),r10 # fetch the last character (reg06)
17981: cmpl r10,$ch$cl # error if it is a semicolon (reg06)
17982: beqlu gtex2
17983: cmpl r10,$ch$sm # or if it is a colon (reg06)
17984: beqlu gtex2
17985: #
17986: # HERE WE CONVERT A STRING BY COMPILATION
17987: #
17988: movl r9,r$cim # set input image pointer
17989: clrl scnpt # set scan pointer
17990: movl r6,scnil # set input image length
17991: clrl r7 # set code for normal scan
17992: movl flptr,gtcef # save fail ptr in case of error
17993: movl r$cod,r$gtc # also save code ptr
17994: movl $stgev,stage # adjust stage for compile
17995: movl $t$uok,scntp # indicate unary operator acceptable
17996: jsb expan # build tree for expression
17997: clrl scnrs # reset rescan flag
17998: cmpl scnpt,scnil # error if not end of image
17999: bnequ gtex2
18000: clrl r7 # set ok value for cdgex call
18001: movl r9,r10 # copy tree pointer
18002: jsb cdgex # build expression block
18003: clrl r$cim # clear pointer
18004: movl $stgxt,stage # restore stage for execute time
18005: #
18006: # MERGE HERE IF NO CONVERSION REQUIRED
18007: #
18008: gtex1: addl2 $4*1,(sp) # return to gtexp caller
18009: rsb
18010: #
18011: # HERE IF UNCONVERTIBLE
18012: #
18013: gtex2: movl (sp)+,r11 # take error exit
18014: jmp *(r11)+
18015: #enp # end procedure gtexp
18016: #page
18017: #
18018: # GTINT -- GET INTEGER VALUE
18019: #
18020: # GTINT IS PASSED AN OBJECT AND RETURNS AN INTEGER AFTER
18021: # PERFORMING ANY NECESSARY CONVERSIONS.
18022: #
18023: # (XR) VALUE TO BE CONVERTED
18024: # JSR GTINT CALL TO CONVERT TO INTEGER
18025: # PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
18026: # (XR) RESULTING INTEGER
18027: # (WC,RA) DESTROYED
18028: # (WA,WB) DESTROYED (ONLY ON CONVERSION ERR)
18029: # (XR) UNCHANGED (ON CONVERT ERROR)
18030: #
18031: gtint: #prc # entry point
18032: cmpl (r9),$b$icl # jump if already an integer
18033: beqlu gtin2
18034: movl r6,gtina # else save wa
18035: movl r7,gtinb # save wb
18036: jsb gtnum # convert to numeric
18037: .long gtin3 # jump if unconvertible
18038: cmpl r6,$b$icl # jump if integer
18039: beqlu gtin1
18040: #
18041: # HERE WE CONVERT A REAL TO INTEGER
18042: #
18043: movf 4*rcval(r9),r2 # load real value
18044: cvtfl r2,r5 # convert to integer (err if ovflow)
18045: bvs gtin3
18046: jsb icbld # if ok build icblk
18047: #
18048: # HERE AFTER SUCCESSFUL CONVERSION TO INTEGER
18049: #
18050: gtin1: movl gtina,r6 # restore wa
18051: movl gtinb,r7 # restore wb
18052: #
18053: # COMMON EXIT POINT
18054: #
18055: gtin2: addl2 $4*1,(sp) # return to gtint caller
18056: rsb
18057: #
18058: # HERE ON CONVERSION ERROR
18059: #
18060: gtin3: movl (sp)+,r11 # take convert error exit
18061: jmp *(r11)+
18062: #enp # end procedure gtint
18063: #page
18064: #
18065: # GTNUM -- GET NUMERIC VALUE
18066: #
18067: # GTNUM IS GIVEN AN OBJECT AND RETURNS EITHER AN INTEGER
18068: # OR A REAL, PERFORMING ANY NECESSARY CONVERSIONS.
18069: #
18070: # (XR) OBJECT TO BE CONVERTED
18071: # JSR GTNUM CALL TO CONVERT TO NUMERIC
18072: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
18073: # (XR) POINTER TO RESULT (INT OR REAL)
18074: # (WA) FIRST WORD OF RESULT BLOCK
18075: # (WB,WC,RA) DESTROYED
18076: # (XR) UNCHANGED (ON CONVERT ERROR)
18077: #
18078: gtnum: #prc # entry point
18079: movl (r9),r6 # load first word of block
18080: cmpl r6,$b$icl # jump if integer (no conversion)
18081: bnequ 0f
18082: jmp gtn34
18083: 0:
18084: cmpl r6,$b$rcl # jump if real (no conversion)
18085: bnequ 0f
18086: jmp gtn34
18087: 0:
18088: #
18089: # AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING
18090: # TO AN INTEGER OR REAL AS APPROPRIATE.
18091: #
18092: movl r9,-(sp) # stack argument in case convert err
18093: movl r9,-(sp) # stack argument for gtstg
18094: jsb gtstg # convert argument to string
18095: .long gtn36 # jump if unconvertible
18096: #
18097: # INITIALIZE NUMERIC CONVERSION
18098: #
18099: movl intv0,r5 # initialize integer result to zero
18100: tstl r6 # jump to exit with zero if null
18101: bnequ 0f
18102: jmp gtn32
18103: 0:
18104: # set bct counter for following loops
18105: clrl gtnnf # tentatively indicate result +
18106: movl r5,gtnex # initialise exponent to zero
18107: clrl gtnsc # zero scale in case real
18108: clrl gtndf # reset flag for dec point found
18109: clrl gtnrd # reset flag for digits found
18110: movf reav0,r2 # zero real accum in case real
18111: movab cfp$f(r9),r9 # point to argument characters
18112: #
18113: # MERGE BACK HERE AFTER IGNORING LEADING BLANK
18114: #
18115: gtn01: movzbl (r9)+,r7 # load first character
18116: cmpl r7,$ch$d0 # jump if not digit
18117: blssu gtn02
18118: cmpl r7,$ch$d9 # jump if first char is a digit
18119: blequ gtn06
18120: #page
18121: #
18122: # GTNUM (CONTINUED)
18123: #
18124: # HERE IF FIRST DIGIT IS NON-DIGIT
18125: #
18126: gtn02: cmpl r7,$ch$bl # jump if non-blank
18127: bnequ gtn03
18128: gtna2: sobgtr r6,gtn01 # else decr count and loop back
18129: jmp gtn07 # jump to return zero if all blanks
18130: #
18131: # HERE FOR FIRST CHARACTER NON-BLANK, NON-DIGIT
18132: #
18133: gtn03: cmpl r7,$ch$pl # jump if plus sign
18134: beqlu gtn04
18135: cmpl r7,$ch$ht # horizontal tab equiv to blank
18136: beqlu gtna2
18137: cmpl r7,$ch$mn # jump if not minus (may be real)
18138: beqlu 0f
18139: jmp gtn12
18140: 0:
18141: movl sp,gtnnf # if minus sign, set negative flag
18142: #
18143: # MERGE HERE AFTER PROCESSING SIGN
18144: #
18145: gtn04: sobgtr r6,gtn05 # jump if chars left
18146: jmp gtn36 # else error
18147: #
18148: # LOOP TO FETCH CHARACTERS OF AN INTEGER
18149: #
18150: gtn05: movzbl (r9)+,r7 # load next character
18151: cmpl r7,$ch$d0 # jump if not a digit
18152: blssu gtn08
18153: cmpl r7,$ch$d9 # jump if not a digit
18154: bgtru gtn08
18155: #
18156: # MERGE HERE FOR FIRST DIGIT
18157: #
18158: gtn06: movl r5,gtnsi # save current value
18159: mull2 $10,r5 # current*10-(new dig) jump if ovflow
18160: bvc 0f
18161: jmp gtn35
18162: 0: bicl2 $0xfffffff0,r7
18163: subl2 r7,r5
18164: bvc 1f
18165: jmp gtn35
18166: 1:
18167: movl sp,gtnrd # set digit read flag
18168: sobgtr r6,gtn05 # else loop back if more chars
18169: #
18170: # HERE TO EXIT WITH CONVERTED INTEGER VALUE
18171: #
18172: gtn07: tstl gtnnf # jump if negative (all set)
18173: beqlu 0f
18174: jmp gtn32
18175: 0:
18176: mnegl r5,r5 # else negate
18177: bvs 0f
18178: jmp gtn32
18179: 0:
18180: jmp gtn36 # else signal error
18181: #page
18182: #
18183: # GTNUM (CONTINUED)
18184: #
18185: # HERE FOR A NON-DIGIT CHARACTER WHILE ATTEMPTING TO
18186: # CONVERT AN INTEGER, CHECK FOR TRAILING BLANKS OR REAL.
18187: #
18188: gtn08: cmpl r7,$ch$bl # jump if a blank
18189: beqlu gtna9
18190: cmpl r7,$ch$ht # jump if horizontal tab
18191: beqlu gtna9
18192: cvtlf r5,r2 # else convert integer to real
18193: mnegf r2,r2 # negate to get positive value
18194: jmp gtn12 # jump to try for real
18195: #
18196: # HERE WE SCAN OUT BLANKS TO END OF STRING
18197: #
18198: gtn09: movzbl (r9)+,r7 # get next char
18199: cmpl r7,$ch$ht # jump if horizontal tab
18200: beqlu gtna9
18201: cmpl r7,$ch$bl # error if non-blank
18202: beqlu 0f
18203: jmp gtn36
18204: 0:
18205: gtna9: sobgtr r6,gtn09 # loop back if more chars to check
18206: jmp gtn07 # return integer if all blanks
18207: #
18208: # LOOP TO COLLECT MANTISSA OF REAL
18209: #
18210: gtn10: movzbl (r9)+,r7 # load next character
18211: cmpl r7,$ch$d0 # jump if non-numeric
18212: bgequ 0f
18213: jmp gtn12
18214: 0:
18215: cmpl r7,$ch$d9 # jump if non-numeric
18216: blequ 0f
18217: jmp gtn12
18218: 0:
18219: #
18220: # MERGE HERE TO COLLECT FIRST REAL DIGIT
18221: #
18222: gtn11: subl2 $ch$d0,r7 # convert digit to number
18223: mulf2 reavt,r2 # multiply real by 10.0
18224: bvc 0f
18225: jmp gtn36
18226: 0:
18227: movf r2,gtnsr # save result
18228: movl r7,r5 # get new digit as integer
18229: cvtlf r5,r2 # convert new digit to real
18230: addf2 gtnsr,r2 # add to get new total
18231: addl2 gtndf,gtnsc # increment scale if after dec point
18232: movl sp,gtnrd # set digit found flag
18233: sobgtr r6,gtn10 # loop back if more chars
18234: jmp gtn22 # else jump to scale
18235: #page
18236: #
18237: # GTNUM (CONTINUED)
18238: #
18239: # HERE IF NON-DIGIT FOUND WHILE COLLECTING A REAL
18240: #
18241: gtn12: cmpl r7,$ch$dt # jump if not dec point
18242: bnequ gtn13
18243: tstl gtndf # if dec point, error if one already
18244: beqlu 0f
18245: jmp gtn36
18246: 0:
18247: movl $num01,gtndf # else set flag for dec point
18248: sobgtr r6,gtn10 # loop back if more chars
18249: jmp gtn22 # else jump to scale
18250: #
18251: # HERE IF NOT DECIMAL POINT
18252: #
18253: gtn13: cmpl r7,$ch$le # jump if e for exponent
18254: beqlu gtn15
18255: cmpl r7,$ch$ld # jump if d for exponent
18256: beqlu gtn15
18257: cmpl r7,$ch$$e # jump if e for exponent
18258: beqlu gtn15
18259: cmpl r7,$ch$$d # jump if d for exponent
18260: beqlu gtn15
18261: #
18262: # HERE CHECK FOR TRAILING BLANKS
18263: #
18264: gtn14: cmpl r7,$ch$bl # jump if blank
18265: beqlu gtnb4
18266: cmpl r7,$ch$ht # jump if horizontal tab
18267: beqlu gtnb4
18268: jmp gtn36 # error if non-blank
18269: #
18270: gtnb4: movzbl (r9)+,r7 # get next character
18271: sobgtr r6,gtn14 # loop back to check if more
18272: jmp gtn22 # else jump to scale
18273: #
18274: # HERE TO READ AND PROCESS AN EXPONENT
18275: #
18276: gtn15: clrl gtnes # set exponent sign positive
18277: movl intv0,r5 # initialize exponent to zero
18278: movl sp,gtndf # reset no dec point indication
18279: sobgtr r6,gtn16 # jump skipping past e or d
18280: jmp gtn36 # error if null exponent
18281: #
18282: # CHECK FOR EXPONENT SIGN
18283: #
18284: gtn16: movzbl (r9)+,r7 # load first exponent character
18285: cmpl r7,$ch$pl # jump if plus sign
18286: beqlu gtn17
18287: cmpl r7,$ch$mn # else jump if not minus sign
18288: bnequ gtn19
18289: movl sp,gtnes # set sign negative if minus sign
18290: #
18291: # MERGE HERE AFTER PROCESSING EXPONENT SIGN
18292: #
18293: gtn17: sobgtr r6,gtn18 # jump if chars left
18294: jmp gtn36 # else error
18295: #
18296: # LOOP TO CONVERT EXPONENT DIGITS
18297: #
18298: gtn18: movzbl (r9)+,r7 # load next character
18299: #page
18300: #
18301: # GTNUM (CONTINUED)
18302: #
18303: # MERGE HERE FOR FIRST EXPONENT DIGIT
18304: #
18305: gtn19: cmpl r7,$ch$d0 # jump if not digit
18306: blssu gtn20
18307: cmpl r7,$ch$d9 # jump if not digit
18308: bgtru gtn20
18309: mull2 $10,r5 # else current*10, subtract new digit
18310: bvc 0f
18311: jmp gtn36
18312: 0: bicl2 $0xfffffff0,r7
18313: subl2 r7,r5
18314: bvc 1f
18315: jmp gtn36
18316: 1:
18317: sobgtr r6,gtn18 # loop back if more chars
18318: jmp gtn21 # jump if exponent field is exhausted
18319: #
18320: # HERE TO CHECK FOR TRAILING BLANKS AFTER EXPONENT
18321: #
18322: gtn20: cmpl r7,$ch$bl # jump if blank
18323: beqlu gtnc0
18324: cmpl r7,$ch$ht # jump if horizontal tab
18325: beqlu gtnc0
18326: jmp gtn36 # error if non-blank
18327: #
18328: gtnc0: movzbl (r9)+,r7 # get next character
18329: sobgtr r6,gtn20 # loop back till all blanks scanned
18330: #
18331: # MERGE HERE AFTER COLLECTING EXPONENT
18332: #
18333: gtn21: movl r5,gtnex # save collected exponent
18334: tstl gtnes # jump if it was negative
18335: bnequ gtn22
18336: mnegl r5,r5 # else complement
18337: bvc 0f
18338: jmp gtn36
18339: 0:
18340: movl r5,gtnex # and store positive exponent
18341: #
18342: # MERGE HERE WITH EXPONENT (0 IF NONE GIVEN)
18343: #
18344: gtn22: tstl gtnrd # error if not digits collected
18345: bnequ 0f
18346: jmp gtn36
18347: 0:
18348: tstl gtndf # error if no exponent or dec point
18349: bnequ 0f
18350: jmp gtn36
18351: 0:
18352: movl gtnsc,r5 # else load scale as integer
18353: subl2 gtnex,r5 # subtract exponent
18354: bvc 0f
18355: jmp gtn36
18356: 0:
18357: tstl r5 # jump if we must scale up
18358: blss gtn26
18359: #
18360: # HERE WE HAVE A NEGATIVE EXPONENT, SO SCALE DOWN
18361: #
18362: movl r5,r6 # load scale factor, err if ovflow
18363: bgeq 0f
18364: jmp gtn36
18365: 0:
18366: #
18367: # LOOP TO SCALE DOWN IN STEPS OF 10**10
18368: #
18369: gtn23: cmpl r6,$num10 # jump if 10 or less to go
18370: blequ gtn24
18371: divf2 reatt,r2 # else divide by 10**10
18372: subl2 $num10,r6 # decrement scale
18373: jmp gtn23 # and loop back
18374: #page
18375: #
18376: # GTNUM (CONTINUED)
18377: #
18378: # HERE SCALE REST OF WAY FROM POWERS OF TEN TABLE
18379: #
18380: gtn24: tstl r6 # jump if scaled
18381: beqlu gtn30
18382: movl $cfp$r,r7 # else get indexing factor
18383: movl $reav1,r9 # point to powers of ten table
18384: moval 0[r6],r6 # convert remaining scale to byte ofs
18385: #
18386: # LOOP TO POINT TO POWERS OF TEN TABLE ENTRY
18387: #
18388: gtn25: addl2 r6,r9 # bump pointer
18389: sobgtr r7,gtn25 # once for each value word
18390: divf2 (r9),r2 # scale down as required
18391: jmp gtn30 # and jump
18392: #
18393: # COME HERE TO SCALE RESULT UP (POSITIVE EXPONENT)
18394: #
18395: gtn26: mnegl r5,r5 # get absolute value of exponent
18396: bvc 0f
18397: jmp gtn36
18398: 0:
18399: movl r5,r6 # acquire scale, error if ovflow
18400: bgeq 0f
18401: jmp gtn36
18402: 0:
18403: #
18404: # LOOP TO SCALE UP IN STEPS OF 10**10
18405: #
18406: gtn27: cmpl r6,$num10 # jump if 10 or less to go
18407: blequ gtn28
18408: mulf2 reatt,r2 # else multiply by 10**10
18409: bvc 0f
18410: jmp gtn36
18411: 0:
18412: subl2 $num10,r6 # else decrement scale
18413: jmp gtn27 # and loop back
18414: #
18415: # HERE TO SCALE UP REST OF WAY WITH TABLE
18416: #
18417: gtn28: tstl r6 # jump if scaled
18418: beqlu gtn30
18419: movl $cfp$r,r7 # else get indexing factor
18420: movl $reav1,r9 # point to powers of ten table
18421: moval 0[r6],r6 # convert remaining scale to byte ofs
18422: #
18423: # LOOP TO POINT TO PROPER ENTRY IN POWERS OF TEN TABLE
18424: #
18425: gtn29: addl2 r6,r9 # bump pointer
18426: sobgtr r7,gtn29 # once for each word in value
18427: mulf2 (r9),r2 # scale up
18428: bvc 0f
18429: jmp gtn36
18430: 0:
18431: #page
18432: #
18433: # GTNUM (CONTINUED)
18434: #
18435: # HERE WITH REAL VALUE SCALED AND READY EXCEPT FOR SIGN
18436: #
18437: gtn30: tstl gtnnf # jump if positive
18438: beqlu gtn31
18439: mnegf r2,r2 # else negate
18440: #
18441: # HERE WITH PROPERLY SIGNED REAL VALUE IN (RA)
18442: #
18443: gtn31: jsb rcbld # build real block
18444: jmp gtn33 # merge to exit
18445: #
18446: # HERE WITH PROPERLY SIGNED INTEGER VALUE IN (IA)
18447: #
18448: gtn32: jsb icbld # build icblk
18449: #
18450: # REAL MERGES HERE
18451: #
18452: gtn33: movl (r9),r6 # load first word of result block
18453: addl2 $4,sp # pop argument off stack
18454: #
18455: # COMMON EXIT POINT
18456: #
18457: gtn34: addl2 $4*1,(sp) # return to gtnum caller
18458: rsb
18459: #
18460: # COME HERE IF OVERFLOW OCCURS DURING COLLECTION OF INTEGER
18461: #
18462: gtn35: movl gtnsi,r5 # reload integer so far
18463: cvtlf r5,r2 # convert to real
18464: mnegf r2,r2 # make value positive
18465: jmp gtn11 # merge with real circuit
18466: #
18467: # HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR
18468: #
18469: gtn36: movl (sp)+,r9 # reload original argument
18470: movl (sp)+,r11 # take convert-error exit
18471: jmp *(r11)+
18472: #enp # end procedure gtnum
18473: #page
18474: #
18475: # GTNVR -- CONVERT TO NATURAL VARIABLE
18476: #
18477: # GTNVR LOCATES A VARIABLE BLOCK (VRBLK) GIVEN EITHER AN
18478: # APPROPRIATE NAME (NMBLK) OR A NON-NULL STRING (SCBLK).
18479: #
18480: # (XR) ARGUMENT
18481: # JSR GTNVR CALL TO CONVERT TO NATURAL VARIABLE
18482: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
18483: # (XR) POINTER TO VRBLK
18484: # (WA,WB) DESTROYED (CONVERSION ERROR ONLY)
18485: # (WC) DESTROYED
18486: #
18487: gtnvr: #prc # entry point
18488: cmpl (r9),$b$nml # jump if not name
18489: bnequ gnv02
18490: movl 4*nmbas(r9),r9 # else load name base if name
18491: cmpl r9,state # skip if vrblk (in static region)
18492: bgtru 0f
18493: jmp gnv07
18494: 0:
18495: #
18496: # COMMON ERROR EXIT
18497: #
18498: gnv01: movl (sp)+,r11 # take convert-error exit
18499: jmp *(r11)+
18500: #
18501: # HERE IF NOT NAME
18502: #
18503: gnv02: movl r6,gnvsa # save wa
18504: movl r7,gnvsb # save wb
18505: movl r9,-(sp) # stack argument for gtstg
18506: jsb gtstg # convert argument to string
18507: .long gnv01 # jump if conversion error
18508: tstl r6 # null string is an error
18509: beqlu gnv01
18510: jsb flstg # fold lower case to upper case
18511: movl r10,-(sp) # save xl
18512: movl r9,-(sp) # stack string ptr for later
18513: movl r9,r7 # copy string pointer
18514: addl2 $4*schar,r7 # point to characters of string
18515: movl r7,gnvst # save pointer to characters
18516: movl r6,r7 # copy length
18517: movab 3+(4*0)(r7),r7 # get number of words in name
18518: ashl $-2,r7,r7
18519: movl r7,gnvnw # save for later
18520: jsb hashs # compute hash index for string
18521: ashq $-32,r4,r4 # compute hash offset by taking mod
18522: ediv hshnb,r4,r11,r5
18523: movl r5,r8 # get as offset
18524: moval 0[r8],r8 # convert offset to bytes
18525: addl2 hshtb,r8 # point to proper hash chain
18526: subl2 $4*vrnxt,r8 # subtract offset to merge into loop
18527: #page
18528: #
18529: # GTNVR (CONTINUED)
18530: #
18531: # LOOP TO SEARCH HASH CHAIN
18532: #
18533: gnv03: movl r8,r10 # copy hash chain pointer
18534: movl 4*vrnxt(r10),r10# point to next vrblk on chain
18535: beqlu gnv08 # jump if end of chain
18536: movl r10,r8 # save pointer to this vrblk
18537: tstl 4*vrlen(r10) # jump if not system variable
18538: bnequ gnv04
18539: movl 4*vrsvp(r10),r10# else point to svblk
18540: subl2 $4*vrsof,r10 # adjust offset for merge
18541: #
18542: # MERGE HERE WITH STRING PTR (LIKE VRBLK) IN XL
18543: #
18544: gnv04: cmpl r6,4*vrlen(r10) # back for next vrblk if lengths ne
18545: bnequ gnv03
18546: addl2 $4*vrchs,r10 # else point to chars of chain entry
18547: movl gnvnw,r7 # get word counter to control loop
18548: movl gnvst,r9 # point to chars of new name
18549: #
18550: # LOOP TO COMPARE CHARACTERS OF THE TWO NAMES
18551: #
18552: gnv05: cmpl (r9),(r10) # jump if no match for next vrblk
18553: bnequ gnv03
18554: addl2 $4,r9 # bump new name pointer
18555: addl2 $4,r10 # bump vrblk in chain name pointer
18556: sobgtr r7,gnv05 # else loop till all compared
18557: movl r8,r9 # we have found a match, get vrblk
18558: #
18559: # EXIT POINT AFTER FINDING VRBLK OR BUILDING NEW ONE
18560: #
18561: gnv06: movl gnvsa,r6 # restore wa
18562: movl gnvsb,r7 # restore wb
18563: addl2 $4,sp # pop string pointer
18564: movl (sp)+,r10 # restore xl
18565: #
18566: # COMMON EXIT POINT
18567: #
18568: gnv07: addl2 $4*1,(sp) # return to gtnvr caller
18569: rsb
18570: #
18571: # NOT FOUND, PREPARE TO SEARCH SYSTEM VARIABLE TABLE
18572: #
18573: gnv08: clrl r9 # clear garbage xr pointer
18574: movl r8,gnvhe # save ptr to end of hash chain
18575: cmpl r6,$num09 # cannot be system var if length gt 9
18576: bgtru gnv14
18577: movl r6,r10 # else copy length
18578: moval 0[r10],r10 # convert to byte offset
18579: movl l^vsrch(r10),r10# point to first svblk of this length
18580: #page
18581: #
18582: # GTNVR (CONTINUED)
18583: #
18584: # LOOP TO SEARCH ENTRIES IN STANDARD VARIABLE TABLE
18585: #
18586: gnv09: movl r10,gnvsp # save table pointer
18587: movl (r10)+,r8 # load svbit bit string
18588: movl (r10)+,r7 # load length from table entry
18589: cmpl r6,r7 # jump if end of right length entires
18590: bnequ gnv14
18591: movl gnvnw,r7 # get word counter to control loop
18592: movl gnvst,r9 # point to chars of new name
18593: #
18594: # LOOP TO CHECK FOR MATCHING NAMES
18595: #
18596: gnv10: cmpl (r9),(r10) # jump if name mismatch
18597: bnequ gnv11
18598: addl2 $4,r9 # else bump new name pointer
18599: addl2 $4,r10 # bump svblk pointer
18600: sobgtr r7,gnv10 # else loop until all checked
18601: #
18602: # HERE WE HAVE A MATCH IN THE STANDARD VARIABLE TABLE
18603: #
18604: clrl r8 # set vrlen value zero
18605: movl $4*vrsi$,r6 # set standard size
18606: jmp gnv15 # jump to build vrblk
18607: #
18608: # HERE IF NO MATCH WITH TABLE ENTRY IN SVBLKS TABLE
18609: #
18610: gnv11: addl2 $4,r10 # bump past word of chars
18611: sobgtr r7,gnv11 # loop back if more to go
18612: ashl $-svnbt,r8,r8 # remove uninteresting bits
18613: #
18614: # LOOP TO BUMP TABLE PTR FOR EACH FLAGGED WORD
18615: #
18616: gnv12: movl bits1,r7 # load bit to test
18617: mcoml r8,r11 # test for word present
18618: bicl2 r11,r7
18619: beqlu gnv13 # jump if not present
18620: addl2 $4,r10 # else bump table pointer
18621: #
18622: # HERE AFTER DEALING WITH ONE WORD (ONE BIT)
18623: #
18624: gnv13: ashl $-1,r8,r8 # remove bit already processed
18625: tstl r8 # loop back if more bits to test
18626: bnequ gnv12
18627: jmp gnv09 # else loop back for next svblk
18628: #
18629: # HERE IF NOT SYSTEM VARIABLE
18630: #
18631: gnv14: movl r6,r8 # copy vrlen value
18632: movl $vrchs,r6 # load standard size -chars
18633: addl2 gnvnw,r6 # adjust for chars of name
18634: moval 0[r6],r6 # convert length to bytes
18635: #page
18636: #
18637: # GTNVR (CONTINUED)
18638: #
18639: # MERGE HERE TO BUILD VRBLK
18640: #
18641: gnv15: jsb alost # allocate space for vrblk (static)
18642: movl r9,r7 # save vrblk pointer
18643: movl $stnvr,r10 # point to model variable block
18644: movl $4*vrlen,r6 # set length of standard fields
18645: jsb sbmvw # set initial fields of new block
18646: movl gnvhe,r10 # load pointer to end of hash chain
18647: movl r7,4*vrnxt(r10) # add new block to end of chain
18648: movl r8,(r9)+ # set vrlen field, bump ptr
18649: movl gnvnw,r6 # get length in words
18650: moval 0[r6],r6 # convert to length in bytes
18651: tstl r8 # jump if system variable
18652: beqlu gnv16
18653: #
18654: # HERE FOR NON-SYSTEM VARIABLE -- SET CHARS OF NAME
18655: #
18656: movl (sp),r10 # point back to string name
18657: addl2 $4*schar,r10 # point to chars of name
18658: jsb sbmvw # move characters into place
18659: movl r7,r9 # restore vrblk pointer
18660: jmp gnv06 # jump back to exit
18661: #
18662: # HERE FOR SYSTEM VARIABLE CASE TO FILL IN FIELDS WHERE
18663: # NECESSARY FROM THE FIELDS PRESENT IN THE SVBLK.
18664: #
18665: gnv16: movl gnvsp,r10 # load pointer to svblk
18666: movl r10,(r9) # set svblk ptr in vrblk
18667: movl r7,r9 # restore vrblk pointer
18668: movl 4*svbit(r10),r7 # load bit indicators
18669: addl2 $4*svchs,r10 # point to characters of name
18670: addl2 r6,r10 # point past characters
18671: #
18672: # SKIP PAST KEYWORD NUMBER (SVKNM) IF PRESENT
18673: #
18674: movl btknm,r8 # load test bit
18675: mcoml r7,r11 # and to test
18676: bicl2 r11,r8
18677: beqlu gnv17 # jump if no keyword number
18678: addl2 $4,r10 # else bump pointer
18679: #page
18680: #
18681: # GTNVR (CONTINUED)
18682: #
18683: # HERE TEST FOR FUNCTION (SVFNC AND SVNAR)
18684: #
18685: gnv17: movl btfnc,r8 # get test bit
18686: mcoml r7,r11 # and to test
18687: bicl2 r11,r8
18688: beqlu gnv18 # skip if no system function
18689: movl r10,4*vrfnc(r9) # else point vrfnc to svfnc field
18690: addl2 $4*num02,r10 # and bump past svfnc, svnar fields
18691: #
18692: # NOW TEST FOR LABEL (SVLBL)
18693: #
18694: gnv18: movl btlbl,r8 # get test bit
18695: mcoml r7,r11 # and to test
18696: bicl2 r11,r8
18697: beqlu gnv19 # jump if bit is off (no system labl)
18698: movl r10,4*vrlbl(r9) # else point vrlbl to svlbl field
18699: addl2 $4,r10 # bump past svlbl field
18700: #
18701: # NOW TEST FOR VALUE (SVVAL)
18702: #
18703: gnv19: movl btval,r8 # load test bit
18704: mcoml r7,r11 # and to test
18705: bicl2 r11,r8
18706: bnequ 0f # all done if no value
18707: jmp gnv06
18708: 0:
18709: movl (r10),4*vrval(r9)# else set initial value
18710: movl $b$vre,4*vrsto(r9) # set error store access
18711: jmp gnv06 # merge back to exit to caller
18712: #enp # end procedure gtnvr
18713: #page
18714: #
18715: # GTPAT -- GET PATTERN
18716: #
18717: # GTPAT IS PASSED AN OBJECT IN (XR) AND RETURNS A
18718: # PATTERN AFTER PERFORMING ANY NECESSARY CONVERSIONS
18719: #
18720: # (XR) INPUT ARGUMENT
18721: # JSR GTPAT CALL TO CONVERT TO PATTERN
18722: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
18723: # (XR) RESULTING PATTERN
18724: # (WA) DESTROYED
18725: # (WB) DESTROYED (ONLY ON CONVERT ERROR)
18726: # (XR) UNCHANGED (ONLY ON CONVERT ERROR)
18727: #
18728: gtpat: #prc # entry point
18729: cmpl (r9),$p$aaa # jump if pattern already
18730: bgequ gtpt5
18731: #
18732: # HERE IF NOT PATTERN, TRY FOR STRING
18733: #
18734: movl r7,gtpsb # save wb
18735: movl r9,-(sp) # stack argument for gtstg
18736: jsb gtstg # convert argument to string
18737: .long gtpt2 # jump if impossible
18738: #
18739: # HERE WE HAVE A STRING
18740: #
18741: tstl r6 # jump if non-null
18742: bnequ gtpt1
18743: #
18744: # HERE FOR NULL STRING. GENERATE POINTER TO NULL PATTERN.
18745: #
18746: movl $ndnth,r9 # point to nothen node
18747: jmp gtpt4 # jump to exit
18748: #page
18749: #
18750: # GTPAT (CONTINUED)
18751: #
18752: # HERE FOR NON-NULL STRING
18753: #
18754: gtpt1: movl $p$str,r7 # load pcode for multi-char string
18755: cmpl r6,$num01 # jump if multi-char string
18756: bnequ gtpt3
18757: #
18758: # HERE FOR ONE CHARACTER STRING, SHARE ONE CHARACTER ANY
18759: #
18760: movab cfp$f(r9),r9 # point to character
18761: movzbl (r9),r6 # load character
18762: movl r6,r9 # set as parm1
18763: movl $p$ans,r7 # point to pcode for 1-char any
18764: jmp gtpt3 # jump to build node
18765: #
18766: # HERE IF ARGUMENT IS NOT CONVERTIBLE TO STRING
18767: #
18768: gtpt2: movl $p$exa,r7 # set pcode for expression in case
18769: cmpl (r9),$b$e$$ # jump to build node if expression
18770: blequ gtpt3
18771: #
18772: # HERE WE HAVE AN ERROR (CONVERSION IMPOSSIBLE)
18773: #
18774: movl (sp)+,r11 # take convert error exit
18775: jmp *(r11)+
18776: #
18777: # MERGE HERE TO BUILD NODE FOR STRING OR EXPRESSION
18778: #
18779: gtpt3: jsb pbild # call routine to build pattern node
18780: #
18781: # COMMON EXIT AFTER SUCCESSFUL CONVERSION
18782: #
18783: gtpt4: movl gtpsb,r7 # restore wb
18784: #
18785: # MERGE HERE TO EXIT OF NO CONVERSION REQUIRED
18786: #
18787: gtpt5: addl2 $4*1,(sp) # return to gtpat caller
18788: rsb
18789: #enp # end procedure gtpat
18790: #page
18791: #
18792: # GTREA -- GET REAL VALUE
18793: #
18794: # GTREA IS PASSED AN OBJECT AND RETURNS A REAL VALUE
18795: # PERFORMING ANY NECESSARY CONVERSIONS.
18796: #
18797: # (XR) OBJECT TO BE CONVERTED
18798: # JSR GTREA CALL TO CONVERT OBJECT TO REAL
18799: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
18800: # (XR) POINTER TO RESULTING REAL
18801: # (WA,WB,WC,RA) DESTROYED
18802: # (XR) UNCHANGED (CONVERT ERROR ONLY)
18803: #
18804: gtrea: #prc # entry point
18805: movl (r9),r6 # get first word of block
18806: cmpl r6,$b$rcl # jump if real
18807: beqlu gtre2
18808: jsb gtnum # else convert argument to numeric
18809: .long gtre3 # jump if unconvertible
18810: cmpl r6,$b$rcl # jump if real was returned
18811: beqlu gtre2
18812: #
18813: # HERE FOR CASE OF AN INTEGER TO CONVERT TO REAL
18814: #
18815: gtre1: movl 4*icval(r9),r5 # load integer
18816: cvtlf r5,r2 # convert to real
18817: jsb rcbld # build rcblk
18818: #
18819: # EXIT WITH REAL
18820: #
18821: gtre2: addl2 $4*1,(sp) # return to gtrea caller
18822: rsb
18823: #
18824: # HERE ON CONVERSION ERROR
18825: #
18826: gtre3: movl (sp)+,r11 # take convert error exit
18827: jmp *(r11)+
18828: #enp # end procedure gtrea
18829: #page
18830: #
18831: # GTSMI -- GET SMALL INTEGER
18832: #
18833: # GTSMI IS PASSED A SNOBOL OBJECT AND RETURNS AN ADDRESS
18834: # INTEGER IN THE RANGE (0 LE N LE DNAMB). SUCH A VALUE CAN
18835: # ONLY BE DERIVED FROM AN INTEGER IN THE APPROPRIATE RANGE.
18836: # SMALL INTEGERS NEVER APPEAR AS SNOBOL VALUES. HOWEVER,
18837: # THEY ARE USED INTERNALLY FOR A VARIETY OF PURPOSES.
18838: #
18839: # -(XS) ARGUMENT TO CONVERT (ON STACK)
18840: # JSR GTSMI CALL TO CONVERT TO SMALL INTEGER
18841: # PPM LOC TRANSFER LOC FOR NOT INTEGER
18842: # PPM LOC TRANSFER LOC FOR LT 0, GT DNAMB
18843: # (XR,WC) RESULTING SMALL INT (TWO COPIES)
18844: # (XS) POPPED
18845: # (RA) DESTROYED
18846: # (WA,WB) DESTROYED (ON CONVERT ERROR ONLY)
18847: # (XR) INPUT ARG (CONVERT ERROR ONLY)
18848: #
18849: .data 1
18850: gtsmi_s: .long 0
18851: .text 0
18852: gtsmi: movl (sp)+,gtsmi_s # entry point
18853: movl (sp)+,r9 # load argument
18854: cmpl (r9),$b$icl # skip if already an integer
18855: beqlu gtsm1
18856: #
18857: # HERE IF NOT AN INTEGER
18858: #
18859: jsb gtint # convert argument to integer
18860: .long gtsm2 # jump if convert is impossible
18861: #
18862: # MERGE HERE WITH INTEGER
18863: #
18864: gtsm1: movl 4*icval(r9),r5 # load integer value
18865: movl r5,r8 # move as one word, jump if ovflow
18866: bgeq 0f
18867: jmp gtsm3
18868: 0:
18869: cmpl r8,mxlen # or if too small
18870: bgtru gtsm3
18871: movl r8,r9 # copy result to xr
18872: addl3 $4*2,gtsmi_s,r11 # return to gtsmi caller
18873: jmp (r11)
18874: #
18875: # HERE IF UNCONVERTIBLE TO INTEGER
18876: #
18877: gtsm2: movl gtsmi_s,r11 # take non-integer error exit
18878: jmp *(r11)+
18879: #
18880: # HERE IF OUT OF RANGE
18881: #
18882: gtsm3: addl3 $4*1,gtsmi_s,r11 # take out-of-range error exit
18883: jmp *(r11)+
18884: #enp # end procedure gtsmi
18885: #page
18886: #
18887: # GTSTG -- GET STRING
18888: #
18889: # GTSTG IS PASSED AN OBJECT AND RETURNS A STRING WITH
18890: # ANY NECESSARY CONVERSIONS PERFORMED.
18891: #
18892: # -(XS) INPUT ARGUMENT (ON STACK)
18893: # JSR GTSTG CALL TO CONVERT TO STRING
18894: # PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
18895: # (XR) POINTER TO RESULTING STRING
18896: # (WA) LENGTH OF STRING IN CHARACTERS
18897: # (XS) POPPED
18898: # (RA) DESTROYED
18899: # (XR) INPUT ARG (CONVERT ERROR ONLY)
18900: #
18901: .data 1
18902: gtstg_s: .long 0
18903: .text 0
18904: gtstg: movl (sp)+,gtstg_s # entry point
18905: movl (sp)+,r9 # load argument, pop stack
18906: cmpl (r9),$b$scl # jump if already a string
18907: bnequ 0f
18908: jmp gts30
18909: 0:
18910: #
18911: # HERE IF NOT A STRING ALREADY
18912: #
18913: gts01: movl r9,-(sp) # restack argument in case error
18914: movl r10,-(sp) # save xl
18915: movl r7,gtsvb # save wb
18916: movl r8,gtsvc # save wc
18917: movl (r9),r6 # load first word of block
18918: cmpl r6,$b$icl # jump to convert integer
18919: beqlu gts05
18920: cmpl r6,$b$rcl # jump to convert real
18921: bnequ 0f
18922: jmp gts10
18923: 0:
18924: cmpl r6,$b$nml # jump to convert name
18925: beqlu gts03
18926: cmpl r6,$b$bct # jump to convert buffer
18927: bnequ 0f
18928: jmp gts32
18929: 0:
18930: #
18931: # HERE ON CONVERSION ERROR
18932: #
18933: gts02: movl (sp)+,r10 # restore xl
18934: movl (sp)+,r9 # reload input argument
18935: movl gtstg_s,r11 # take convert error exit
18936: jmp *(r11)+
18937: #page
18938: #
18939: # GTSTG (CONTINUED)
18940: #
18941: # HERE TO CONVERT A NAME (ONLY POSSIBLE IF NATURAL VAR)
18942: #
18943: gts03: movl 4*nmbas(r9),r10 # load name base
18944: cmpl r10,state # error if not natural var (static)
18945: bgequ gts02
18946: addl2 $4*vrsof,r10 # else point to possible string name
18947: movl 4*sclen(r10),r6 # load length
18948: bnequ gts04 # jump if not system variable
18949: movl 4*vrsvo(r10),r10# else point to svblk
18950: movl 4*svlen(r10),r6 # and load name length
18951: #
18952: # MERGE HERE WITH STRING IN XR, LENGTH IN WA
18953: #
18954: gts04: clrl r7 # set offset to zero
18955: jsb sbstr # use sbstr to copy string
18956: jmp gts29 # jump to exit
18957: #
18958: # COME HERE TO CONVERT AN INTEGER
18959: #
18960: gts05: movl 4*icval(r9),r5 # load integer value
18961: movl $num01,gtssf # set sign flag negative
18962: tstl r5 # skip if integer is negative
18963: blss gts06
18964: mnegl r5,r5 # else negate integer
18965: clrl gtssf # and reset negative flag
18966: #page
18967: #
18968: # GTSTG (CONTINUED)
18969: #
18970: # HERE WITH SIGN FLAG SET AND SIGN FORCED NEGATIVE AS
18971: # REQUIRED BY THE CVD INSTRUCTION.
18972: #
18973: gts06: movl gtswk,r9 # point to result work area
18974: movl $nstmx,r7 # initialize counter to max length
18975: movab cfp$f(r9)[r7],r9# prepare to store (right-left)
18976: #
18977: # LOOP TO CONVERT DIGITS INTO WORK AREA
18978: #
18979: gts07: ashq $-32,r4,r4 # convert one digit into wa
18980: ediv $10,r4,r5,r6
18981: mnegl r6,r6
18982: bisb2 $0x30,r6
18983: movb r6,-(r9) # store in work area
18984: decl r7 # decrement counter
18985: tstl r5 # loop if more digits to go
18986: bneq gts07
18987: #csc r9 # complete store characters
18988: #
18989: # MERGE HERE AFTER CONVERTING INTEGER OR REAL INTO WORK
18990: # AREA. WB IS SET TO NSTMX - (NUMBER OF CHARS IN RESULT).
18991: #
18992: gts08: movl $nstmx,r6 # get max number of characters
18993: subl2 r7,r6 # compute length of result
18994: movl r6,r10 # remember length for move later on
18995: addl2 gtssf,r6 # add one for negative sign if needed
18996: jsb alocs # allocate string for result
18997: movl r9,r8 # save result pointer for the moment
18998: movab cfp$f(r9),r9 # point to chars of result block
18999: tstl gtssf # skip if positive
19000: beqlu gts09
19001: movl $ch$mn,r6 # else load negative sign
19002: movb r6,(r9)+ # and store it
19003: #csc r9 # complete store characters
19004: #
19005: # HERE AFTER DEALING WITH SIGN
19006: #
19007: gts09: movl r10,r6 # recall length to move
19008: movl gtswk,r10 # point to result work area
19009: movab cfp$f(r10)[r7],r10 # point to first result character
19010: jsb sbmvc # move chars to result string
19011: movl r8,r9 # restore result pointer
19012: jmp gts29 # jump to exit
19013: #page
19014: #
19015: # GTSTG (CONTINUED)
19016: #
19017: # HERE TO CONVERT A REAL
19018: #
19019: gts10: movf 4*rcval(r9),r2 # load real
19020: clrl gtssf # reset negative flag
19021: tstf r2 # skip if zero
19022: bneq 0f
19023: jmp gts31
19024: 0:
19025: tstf r2 # jump if real is positive
19026: bgeq gts11
19027: movl $num01,gtssf # else set negative flag
19028: mnegf r2,r2 # and get absolute value of real
19029: #
19030: # NOW SCALE THE REAL TO THE RANGE (0.1 LE X LT 1.0)
19031: #
19032: gts11: movl intv0,r5 # initialize exponent to zero
19033: #
19034: # LOOP TO SCALE UP IN STEPS OF 10**10
19035: #
19036: gts12: movf r2,gtsrs # save real value
19037: subf2 reap1,r2 # subtract 0.1 to compare
19038: tstf r2 # jump if scale up not required
19039: bgeq gts13
19040: movf gtsrs,r2 # else reload value
19041: mulf2 reatt,r2 # multiply by 10**10
19042: subl2 intvt,r5 # decrement exponent by 10
19043: jmp gts12 # loop back to test again
19044: #
19045: # TEST FOR SCALE DOWN REQUIRED
19046: #
19047: gts13: movf gtsrs,r2 # reload value
19048: subf2 reav1,r2 # subtract 1.0
19049: tstf r2 # jump if no scale down required
19050: blss gts17
19051: movf gtsrs,r2 # else reload value
19052: #
19053: # LOOP TO SCALE DOWN IN STEPS OF 10**10
19054: #
19055: gts14: subf2 reatt,r2 # subtract 10**10 to compare
19056: tstf r2 # jump if large step not required
19057: blss gts15
19058: movf gtsrs,r2 # else restore value
19059: divf2 reatt,r2 # divide by 10**10
19060: movf r2,gtsrs # store new value
19061: addl2 intvt,r5 # increment exponent by 10
19062: jmp gts14 # loop back
19063: #page
19064: #
19065: # GTSTG (CONTINUED)
19066: #
19067: # AT THIS POINT WE HAVE (1.0 LE X LT 10**10)
19068: # COMPLETE SCALING WITH POWERS OF TEN TABLE
19069: #
19070: gts15: movl $reav1,r9 # point to powers of ten table
19071: #
19072: # LOOP TO LOCATE CORRECT ENTRY IN TABLE
19073: #
19074: gts16: movf gtsrs,r2 # reload value
19075: addl2 intv1,r5 # increment exponent
19076: addl2 $4*cfp$r,r9 # point to next entry in table
19077: subf2 (r9),r2 # subtract it to compare
19078: tstf r2 # loop till we find a larger entry
19079: bgeq gts16
19080: movf gtsrs,r2 # then reload the value
19081: divf2 (r9),r2 # and complete scaling
19082: movf r2,gtsrs # store value
19083: #
19084: # WE ARE NOW SCALED, SO ROUND BY ADDING 0.5 * 10**(-CFP$S)
19085: #
19086: gts17: movf gtsrs,r2 # get value again
19087: addf2 gtsrn,r2 # add rounding factor
19088: movf r2,gtsrs # store result
19089: #
19090: # THE ROUNDING OPERATION MAY HAVE PUSHED US UP PAST
19091: # 1.0 AGAIN, SO CHECK ONE MORE TIME.
19092: #
19093: subf2 reav1,r2 # subtract 1.0 to compare
19094: tstf r2 # skip if ok
19095: blss gts18
19096: addl2 intv1,r5 # else increment exponent
19097: movf gtsrs,r2 # reload value
19098: divf2 reavt,r2 # divide by 10.0 to rescale
19099: jmp gts19 # jump to merge
19100: #
19101: # HERE IF ROUNDING DID NOT MUCK UP SCALING
19102: #
19103: gts18: movf gtsrs,r2 # reload rounded value
19104: #page
19105: #
19106: # GTSTG (CONTINUED)
19107: #
19108: # NOW WE HAVE COMPLETED THE SCALING AS FOLLOWS
19109: #
19110: # (IA) SIGNED EXPONENT
19111: # (RA) SCALED REAL (ABSOLUTE VALUE)
19112: #
19113: # IF THE EXPONENT IS NEGATIVE OR GREATER THAN CFP$S, THEN
19114: # WE CONVERT THE NUMBER IN THE FORM.
19115: #
19116: # (NEG SIGN) 0 . (CPF$S DIGITS) E (EXP SIGN) (EXP DIGITS)
19117: #
19118: # IF THE EXPONENT IS POSITIVE AND LESS THAN OR EQUAL TO
19119: # CFP$S, THE NUMBER IS CONVERTED IN THE FORM.
19120: #
19121: # (NEG SIGN) (EXPONENT DIGITS) . (CFP$S-EXPONENT DIGITS)
19122: #
19123: # IN BOTH CASES, THE FORMATS OBTAINED FROM THE ABOVE
19124: # RULES ARE MODIFIED BY DELETING TRAILING ZEROS AFTER THE
19125: # DECIMAL POINT. THERE ARE NO LEADING ZEROS IN THE EXPONENT
19126: # AND THE EXPONENT SIGN IS ALWAYS PRESENT.
19127: #
19128: gts19: movl $cfp$s,r10 # set num dec digits = cfp$s
19129: movl $ch$mn,gtses # set exponent sign negative
19130: tstl r5 # all set if exponent is negative
19131: blss gts21
19132: movl r5,r6 # else fetch exponent
19133: cmpl r6,$cfp$s # skip if we can use special format
19134: blequ gts20
19135: movl r6,r5 # else restore exponent
19136: mnegl r5,r5 # set negative for cvd
19137: movl $ch$pl,gtses # set plus sign for exponent sign
19138: jmp gts21 # jump to generate exponent
19139: #
19140: # HERE IF WE CAN USE THE FORMAT WITHOUT AN EXPONENT
19141: #
19142: gts20: subl2 r6,r10 # compute digits after decimal point
19143: movl intv0,r5 # reset exponent to zero
19144: #page
19145: #
19146: # GTSTG (CONTINUED)
19147: #
19148: # MERGE HERE AS FOLLOWS
19149: #
19150: # (IA) EXPONENT ABSOLUTE VALUE
19151: # GTSES CHARACTER FOR EXPONENT SIGN
19152: # (RA) POSITIVE FRACTION
19153: # (XL) NUMBER OF DIGITS AFTER DEC POINT
19154: #
19155: gts21: movl gtswk,r9 # point to work area
19156: movl $nstmx,r7 # set character ctr to max length
19157: movab cfp$f(r9)[r7],r9# prepare to store (right to left)
19158: tstl r5 # skip exponent if it is zero
19159: beql gts23
19160: #
19161: # LOOP TO GENERATE DIGITS OF EXPONENT
19162: #
19163: gts22: ashq $-32,r4,r4 # convert a digit into wa
19164: ediv $10,r4,r5,r6
19165: mnegl r6,r6
19166: bisb2 $0x30,r6
19167: movb r6,-(r9) # store in work area
19168: decl r7 # decrement counter
19169: tstl r5 # loop back if more digits to go
19170: bneq gts22
19171: #
19172: # HERE GENERATE EXPONENT SIGN AND E
19173: #
19174: movl gtses,r6 # load exponent sign
19175: movb r6,-(r9) # store in work area
19176: movl $ch$le,r6 # get character letter e
19177: movb r6,-(r9) # store in work area
19178: subl2 $num02,r7 # decrement counter for sign and e
19179: #
19180: # HERE TO GENERATE THE FRACTION
19181: #
19182: gts23: mulf2 gtssc,r2 # convert real to integer (10**cfp$s)
19183: cvtfl r2,r5 # get integer (overflow impossible)
19184: mnegl r5,r5 # negate as required by cvd
19185: #
19186: # LOOP TO SUPPRESS TRAILING ZEROS
19187: #
19188: gts24: tstl r10 # jump if no digits left to do
19189: beqlu gts27
19190: ashq $-32,r4,r4 # else convert one digit
19191: ediv $10,r4,r5,r6
19192: mnegl r6,r6
19193: bisb2 $0x30,r6
19194: cmpl r6,$ch$d0 # jump if not a zero
19195: bnequ gts26
19196: decl r10 # decrement counter
19197: jmp gts24 # loop back for next digit
19198: #page
19199: #
19200: # GTSTG (CONTINUED)
19201: #
19202: # LOOP TO GENERATE DIGITS AFTER DECIMAL POINT
19203: #
19204: gts25: ashq $-32,r4,r4 # convert a digit into wa
19205: ediv $10,r4,r5,r6
19206: mnegl r6,r6
19207: bisb2 $0x30,r6
19208: #
19209: # MERGE HERE FIRST TIME
19210: #
19211: gts26: movb r6,-(r9) # store digit
19212: decl r7 # decrement counter
19213: decl r10 # decrement counter
19214: bnequ gts25 # loop back if more to go
19215: #
19216: # HERE GENERATE THE DECIMAL POINT
19217: #
19218: gts27: movl $ch$dt,r6 # load decimal point
19219: movb r6,-(r9) # store in work area
19220: decl r7 # decrement counter
19221: #
19222: # HERE GENERATE THE DIGITS BEFORE THE DECIMAL POINT
19223: #
19224: gts28: ashq $-32,r4,r4 # convert a digit into wa
19225: ediv $10,r4,r5,r6
19226: mnegl r6,r6
19227: bisb2 $0x30,r6
19228: movb r6,-(r9) # store in work area
19229: decl r7 # decrement counter
19230: tstl r5 # loop back if more to go
19231: bneq gts28
19232: #csc r9 # complete store characters
19233: jmp gts08 # else jump back to exit
19234: #
19235: # EXIT POINT AFTER SUCCESSFUL CONVERSION
19236: #
19237: gts29: movl (sp)+,r10 # restore xl
19238: addl2 $4,sp # pop argument
19239: movl gtsvb,r7 # restore wb
19240: movl gtsvc,r8 # restore wc
19241: #
19242: # MERGE HERE IF NO CONVERSION REQUIRED
19243: #
19244: gts30: movl 4*sclen(r9),r6 # load string length
19245: addl3 $4*1,gtstg_s,r11 # return to caller
19246: jmp (r11)
19247: #
19248: # HERE TO RETURN STRING FOR REAL ZERO
19249: #
19250: gts31: movl $scre0,r10 # point to string
19251: movl $num02,r6 # 2 chars
19252: clrl r7 # zero offset
19253: jsb sbstr # copy string
19254: jmp gts29 # return
19255: #page
19256: #
19257: # HERE TO CONVERT A BUFFER BLOCK
19258: #
19259: gts32: movl r9,r10 # copy arg ptr
19260: movl 4*bclen(r10),r6 # get size to allocate
19261: beqlu gts33 # if null then return null
19262: jsb alocs # allocate string frame
19263: movl r9,r7 # save string ptr
19264: movl 4*sclen(r9),r6 # get length to move
19265: movab 3+(4*0)(r6),r6 # get as multiple of word size
19266: bicl2 $3,r6
19267: movl 4*bcbuf(r10),r10# point to bfblk
19268: addl2 $4*scsi$,r9 # point to start of character area
19269: addl2 $4*bfsi$,r10 # point to start of buffer chars
19270: jsb sbmvw # copy words
19271: movl r7,r9 # restore scblk ptr
19272: jmp gts29 # exit with scblk
19273: #
19274: # HERE WHEN NULL BUFFER IS BEING CONVERTED
19275: #
19276: gts33: movl $nulls,r9 # point to null
19277: jmp gts29 # exit with null
19278: #enp # end procedure gtstg
19279: #page
19280: #
19281: # GTVAR -- GET VARIABLE FOR I/O/TRACE ASSOCIATION
19282: #
19283: # GTVAR IS USED TO POINT TO AN ACTUAL VARIABLE LOCATION
19284: # FOR THE DETACH,INPUT,OUTPUT,TRACE,STOPTR SYSTEM FUNCTIONS
19285: #
19286: # (XR) ARGUMENT TO FUNCTION
19287: # JSR GTVAR CALL TO LOCATE VARIABLE POINTER
19288: # PPM LOC TRANSFER LOC IF NOT OK VARIABLE
19289: # (XL,WA) NAME BASE,OFFSET OF VARIABLE
19290: # (XR,RA) DESTROYED
19291: # (WB,WC) DESTROYED (CONVERT ERROR ONLY)
19292: # (XR) INPUT ARG (CONVERT ERROR ONLY)
19293: #
19294: gtvar: #prc # entry point
19295: cmpl (r9),$b$nml # jump if not a name
19296: bnequ gtvr2
19297: movl 4*nmofs(r9),r6 # else load name offset
19298: movl 4*nmbas(r9),r10 # load name base
19299: cmpl (r10),$b$evt # error if expression variable
19300: beqlu gtvr1
19301: cmpl (r10),$b$kvt # all ok if not keyword variable
19302: bnequ gtvr3
19303: #
19304: # HERE ON CONVERSION ERROR
19305: #
19306: gtvr1: movl (sp)+,r11 # take convert error exit
19307: jmp *(r11)+
19308: #
19309: # HERE IF NOT A NAME, TRY CONVERT TO NATURAL VARIABLE
19310: #
19311: gtvr2: movl r8,gtvrc # save wc
19312: jsb gtnvr # locate vrblk if possible
19313: .long gtvr1 # jump if convert error
19314: movl r9,r10 # else copy vrblk name base
19315: movl $4*vrval,r6 # and set offset
19316: movl gtvrc,r8 # restore wc
19317: #
19318: # HERE FOR NAME OBTAINED
19319: #
19320: gtvr3: cmpl r10,state # all ok if not natural variable
19321: bgequ gtvr4
19322: cmpl 4*vrsto(r10),$b$vre # error if protected variable
19323: beqlu gtvr1
19324: #
19325: # COMMON EXIT POINT
19326: #
19327: gtvr4: addl2 $4*1,(sp) # return to caller
19328: rsb
19329: #enp # end procedure gtvar
19330: #page
19331: #
19332: # HASHS -- COMPUTE HASH INDEX FOR STRING
19333: #
19334: # HASHS IS USED TO CONVERT A STRING TO A UNIQUE INTEGER
19335: # VALUE. THE RESULTING HASH VALUE IS A POSITIVE INTEGER
19336: # IN THE RANGE 0 TO CFP$M
19337: #
19338: # (XR) STRING TO BE HASHED
19339: # JSR HASHS CALL TO HASH STRING
19340: # (IA) HASH VALUE
19341: # (XR,WB,WC) DESTROYED
19342: #
19343: # THE HASH FUNCTION USED IS AS FOLLOWS.
19344: #
19345: # START WITH THE LENGTH OF THE STRING (SGD07)
19346: #
19347: # TAKE THE FIRST E$HNW WORDS OF THE CHARACTERS FROM
19348: # THE STRING OR ALL THE WORDS IF FEWER THAN E$HNW.
19349: #
19350: # COMPUTE THE EXCLUSIVE OR OF ALL THESE WORDS TREATING
19351: # THEM AS ONE WORD BIT STRING VALUES.
19352: #
19353: # MOVE THE RESULT AS AN INTEGER WITH THE MTI INSTRUCTION.
19354: #
19355: hashs: #prc # entry point
19356: movl 4*sclen(r9),r8 # load string length in characters
19357: movl r8,r7 # initialize with length
19358: tstl r8 # jump if null string
19359: beqlu hshs3
19360: movab 3+(4*0)(r8),r8 # else get number of words of chars
19361: ashl $-2,r8,r8
19362: addl2 $4*schar,r9 # point to characters of string
19363: cmpl r8,$e$hnw # use whole string if short
19364: blequ hshs1
19365: movl $e$hnw,r8 # else set to involve first e$hnw wds
19366: #
19367: # HERE WITH COUNT OF WORDS TO CHECK IN WC
19368: #
19369: hshs1: # set counter to control loop
19370: #
19371: # LOOP TO COMPUTE EXCLUSIVE OR
19372: #
19373: hshs2: xorl2 (r9)+,r7 # exclusive or next word of chars
19374: sobgtr r8,hshs2 # loop till all processed
19375: #
19376: # MERGE HERE WITH EXCLUSIVE OR IN WB
19377: #
19378: hshs3: #zgb r7 # zeroise undefined bits
19379: mcoml bitsm,r11 # ensure in range 0 to cfp$m
19380: bicl2 r11,r7
19381: movl r7,r5 # move result as integer
19382: clrl r9 # clear garbage value in xr
19383: rsb # return to hashs caller
19384: #enp # end procedure hashs
19385: #page
19386: #
19387: # ICBLD -- BUILD INTEGER BLOCK
19388: #
19389: # (IA) INTEGER VALUE FOR ICBLK
19390: # JSR ICBLD CALL TO BUILD INTEGER BLOCK
19391: # (XR) POINTER TO RESULT ICBLK
19392: # (WA) DESTROYED
19393: #
19394: icbld: #prc # entry point
19395: movl r5,r9 # copy small integers
19396: bgeq 0f
19397: jmp icbl1
19398: 0:
19399: cmpl r9,$num02 # jump if 0,1 or 2
19400: blequ icbl3
19401: #
19402: # CONSTRUCT ICBLK
19403: #
19404: icbl1: movl dnamp,r9 # load pointer to next available loc
19405: addl2 $4*icsi$,r9 # point past new icblk
19406: cmpl r9,dname # jump if there is room
19407: blequ icbl2
19408: movl $4*icsi$,r6 # else load length of icblk
19409: jsb alloc # use standard allocator to get block
19410: addl2 r6,r9 # point past block to merge
19411: #
19412: # MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
19413: #
19414: icbl2: movl r9,dnamp # set new pointer
19415: subl2 $4*icsi$,r9 # point back to start of block
19416: movl $b$icl,(r9) # store type word
19417: movl r5,4*icval(r9) # store integer value in icblk
19418: rsb # return to icbld caller
19419: #
19420: # OPTIMISE BY NOT BUILDING ICBLKS FOR SMALL INTEGERS
19421: #
19422: icbl3: moval 0[r9],r9 # convert integer to offset
19423: movl l^intab(r9),r9 # point to pre-built icblk
19424: rsb # return
19425: #enp # end procedure icbld
19426: #page
19427: #
19428: # IDENT -- COMPARE TWO VALUES
19429: #
19430: # IDENT COMPARES TWO VALUES IN THE SENSE OF THE IDENT
19431: # DIFFER FUNCTIONS AVAILABLE AT THE SNOBOL LEVEL.
19432: #
19433: # (XR) FIRST ARGUMENT
19434: # (XL) SECOND ARGUMENT
19435: # JSR IDENT CALL TO COMPARE ARGUMENTS
19436: # PPM LOC TRANSFER LOC IF IDENT
19437: # (NORMAL RETURN IF DIFFER)
19438: # (XR,XL,WC,RA) DESTROYED
19439: #
19440: ident: #prc # entry point
19441: cmpl r9,r10 # jump if same pointer (ident)
19442: bnequ 0f
19443: jmp iden7
19444: 0:
19445: movl (r9),r8 # else load arg 1 type word
19446: cmpl r8,(r10) # differ if arg 2 type word differ
19447: bnequ iden1
19448: cmpl r8,$b$scl # jump if strings
19449: beqlu iden2
19450: cmpl r8,$b$icl # jump if integers
19451: beqlu iden4
19452: cmpl r8,$b$rcl # jump if reals
19453: beqlu iden5
19454: cmpl r8,$b$nml # jump if names
19455: beqlu iden6
19456: #
19457: # FOR ALL OTHER DATATYPES, MUST BE DIFFER IF XR NE XL
19458: #
19459: # MERGE HERE FOR DIFFER
19460: #
19461: iden1: addl2 $4*1,(sp) # take differ exit
19462: rsb
19463: #
19464: # HERE FOR STRINGS, IDENT ONLY IF LENGTHS AND CHARS SAME
19465: #
19466: iden2: movl 4*sclen(r9),r8 # load arg 1 length
19467: cmpl r8,4*sclen(r10) # differ if lengths differ
19468: bnequ iden1
19469: movab 3+(4*0)(r8),r8 # get number of words in strings
19470: ashl $-2,r8,r8
19471: addl2 $4*schar,r9 # point to chars of arg 1
19472: addl2 $4*schar,r10 # point to chars of arg 2
19473: # set loop counter
19474: #
19475: # LOOP TO COMPARE CHARACTERS. NOTE THAT WA CANNOT BE ZERO
19476: # SINCE ALL NULL STRINGS POINT TO NULLS AND GIVE XL=XR.
19477: #
19478: iden3: cmpl (r9),(r10) # differ if chars do not match
19479: bnequ iden8
19480: addl2 $4,r9 # else bump arg one pointer
19481: addl2 $4,r10 # bump arg two pointer
19482: sobgtr r8,iden3 # loop back till all checked
19483: #page
19484: #
19485: # IDENT (CONTINUED)
19486: #
19487: # HERE TO EXIT FOR CASE OF TWO IDENT STRINGS
19488: #
19489: clrl r10 # clear garbage value in xl
19490: clrl r9 # clear garbage value in xr
19491: movl (sp)+,r11 # take ident exit
19492: jmp *(r11)+
19493: #
19494: # HERE FOR INTEGERS, IDENT IF SAME VALUES
19495: #
19496: iden4: movl 4*icval(r9),r5 # load arg 1
19497: subl2 4*icval(r10),r5 # subtract arg 2 to compare
19498: bvs iden1
19499: tstl r5 # differ if result is not zero
19500: bneq iden1
19501: movl (sp)+,r11 # take ident exit
19502: jmp *(r11)+
19503: #
19504: # HERE FOR REALS, IDENT IF SAME VALUES
19505: #
19506: iden5: movf 4*rcval(r9),r2 # load arg 1
19507: subf2 4*rcval(r10),r2 # subtract arg 2 to compare
19508: bvs iden1
19509: tstf r2 # differ if result is not zero
19510: bneq iden1
19511: movl (sp)+,r11 # take ident exit
19512: jmp *(r11)+
19513: #
19514: # HERE FOR NAMES, IDENT IF BASES AND OFFSETS SAME
19515: #
19516: iden6: cmpl 4*nmofs(r9),4*nmofs(r10) # differ if different offset
19517: bnequ iden1
19518: cmpl 4*nmbas(r9),4*nmbas(r10) # differ if different base
19519: bnequ iden1
19520: #
19521: # MERGE HERE TO SIGNAL IDENT FOR IDENTICAL POINTERS
19522: #
19523: iden7: movl (sp)+,r11 # take ident exit
19524: jmp *(r11)+
19525: #
19526: # HERE FOR DIFFER STRINGS
19527: #
19528: iden8: clrl r9 # clear garbage ptr in xr
19529: clrl r10 # clear garbage ptr in xl
19530: addl2 $4*1,(sp) # return to caller (differ)
19531: rsb
19532: #enp # end procedure ident
19533: #page
19534: #
19535: # INOUT - USED TO INITIALISE INPUT AND OUTPUT VARIABLES
19536: #
19537: # (XL) POINTER TO VBL NAME STRING
19538: # (WB) TRBLK TYPE
19539: # JSR INOUT CALL TO PERFORM INITIALISATION
19540: # (XL) VRBLK PTR
19541: # (XR) TRBLK PTR
19542: # (WA,WC) DESTROYED
19543: #
19544: # NOTE THAT TRTER (= TRTRF) FIELD OF STANDARD I/O VARIABLES
19545: # POINTS TO CORRESPONDING SVBLK NOT TO A TRBLK AS IS THE
19546: # CASE FOR ORDINARY VARIABLES.
19547: #
19548: inout: #prc # entry point
19549: movl r7,-(sp) # stack trblk type
19550: movl 4*sclen(r10),r6 # get name length
19551: clrl r7 # point to start of name
19552: jsb sbstr # build a proper scblk
19553: jsb gtnvr # build vrblk
19554: .long invalid$ # no error return
19555: movl r9,r8 # save vrblk pointer
19556: movl (sp)+,r7 # get trter field
19557: clrl r10 # zero trfpt
19558: jsb trbld # build trblk
19559: movl r8,r10 # recall vrblk pointer
19560: movl 4*vrsvp(r10),4*trter(r9) # store svblk pointer
19561: movl r9,4*vrval(r10) # store trblk ptr in vrblk
19562: movl $b$vra,4*vrget(r10) # set trapped access
19563: movl $b$vrv,4*vrsto(r10) # set trapped store
19564: rsb # return to caller
19565: #enp # end procedure inout
19566: #page
19567: #
19568: # INSBF -- INSERT STRING IN BUFFER
19569: #
19570: # THIS ROUTINE WILL REPLACE A SECTION OF A BUFFER WITH THE
19571: # CONTENTS OF A GIVEN STRING. IF THE LENGTH OF THE
19572: # SECTION TO BE REPLACED IS DIFFERENT THAN THE LENGTH OF
19573: # THE GIVEN STRING, AND THE REPLACEMENT IS NOT AN APPEND,
19574: # THEN THE UPPER SECTION OF THE BUFFER IS SHIFTED UP OR
19575: # DOWN TO CREATE THE PROPER SPACE FOR THE INSERT.
19576: #
19577: # (XR) POINTER TO BFBLK
19578: # (XL) OBJECT WHICH IS STRING CONVERTABLE
19579: # (WA) OFFSET OF START OF INSERT IN (XR)
19580: # (WB) LENGTH OF SECTION IN (XR) REPLACED
19581: # JSR INSBF CALL TO INSERT CHARACTERS IN BUFFER
19582: # PPM LOC THREAD IF (XR) NOT CONVERTABLE
19583: # PPM LOC THREAD IF INSERT NOT POSSIBLE
19584: #
19585: # THE SECOND ALTERNATE EXIT IS TAKEN IF THE INSERT WOULD
19586: # OVERFLOW THE BUFFER, OR IF THE INSERT IS OUT PAST THE
19587: # DEFINED END OF THE BUFFER AS GIVEN.
19588: #
19589: insbf: #prc # entry point
19590: movl r6,inssa # save entry wa
19591: movl r7,inssb # save entry wb
19592: movl r8,inssc # save entry wc
19593: addl2 r7,r6 # add to get offset past replace part
19594: movl r6,insab # save wa+wb
19595: movl 4*bclen(r9),r8 # get current defined length
19596: cmpl inssa,r8 # fail if start offset too big
19597: blequ 0f
19598: jmp ins07
19599: 0:
19600: cmpl r6,r8 # fail if final offset too big
19601: blequ 0f
19602: jmp ins07
19603: 0:
19604: movl r10,-(sp) # save entry xl
19605: movl r9,-(sp) # save bcblk ptr
19606: movl r10,-(sp) # stack again for gtstg
19607: jsb gtstg # call to convert to string
19608: .long ins05 # take string convert err exit
19609: movl r9,r10 # save string ptr
19610: movl (sp),r9 # restore bcblk ptr
19611: addl2 r8,r6 # add buffer len to string len
19612: subl2 inssb,r6 # bias out component being replaced
19613: movl 4*bcbuf(r9),r9 # point to bfblk
19614: cmpl r6,4*bfalc(r9) # fail if result exceeds allocation
19615: blequ 0f
19616: jmp ins06
19617: 0:
19618: movl (sp),r9 # restore bcblk ptr
19619: movl r8,r6 # get buffer length
19620: subl2 insab,r6 # subtract to get shift length
19621: addl2 4*sclen(r10),r8 # add length of new
19622: subl2 inssb,r8 # subtract old to get total new len
19623: movl 4*bclen(r9),r7 # get old bclen
19624: movl r8,4*bclen(r9) # stuff new length
19625: tstl r6 # skip shift if nothing to do
19626: bnequ 0f
19627: jmp ins04
19628: 0:
19629: cmpl inssb,4*sclen(r10) # skip shift if lengths match
19630: bnequ 0f
19631: jmp ins04
19632: 0:
19633: movl 4*bcbuf(r9),r9 # point to bfblk
19634: movl r10,-(sp) # save scblk ptr
19635: cmpl inssb,4*sclen(r10) # brn if shft is for more room
19636: blequ ins01
19637: #page
19638: #
19639: # INSBF (CONTINUED)
19640: #
19641: # WE ARE SHIFTING THE UPPER SEGMENT DOWN TO COMPACT
19642: # THE BUFFER. (THE STRING LENGTH IS SMALLER THAN THE
19643: # SEGMENT BEING REPLACED.) REGISTERS ARE SET AS:
19644: #
19645: # (WA) MOVE (SHIFT DOWN) LENGTH
19646: # (WB) OLD BCLEN
19647: # (WC) NEW BCLEN
19648: # (XR) BFBLK PTR
19649: # (XL),(XS) SCBLK PTR
19650: #
19651: movl inssa,r7 # get offset to insert
19652: addl2 4*sclen(r10),r7 # add insert length to get dest off
19653: movl r9,r10 # make copy
19654: movl insab,r11 # [get in scratch register]
19655: movab cfp$f(r10)[r11],r10 # prepare source for move
19656: movab cfp$f(r9)[r7],r9# prepare destination reg for move
19657: jsb sbmvc # move em out
19658: jmp ins02 # branch to pad
19659: #
19660: # WE ARE SHIFTING THE UPPER SEGMENT UP TO EXPAND
19661: # THE BUFFER. (THE STRING LENGTH IS LARGER THAN THE
19662: # SEGMENT BEING REPLACED.)
19663: #
19664: ins01: movl r9,r10 # copy bfblk ptr
19665: movab cfp$f(r10)[r7],r10 # set source reg for move backwards
19666: movab cfp$f(r9)[r8],r9# set destination ptr for move
19667: jsb sbmcb # move backwards (possible overlap)
19668: #
19669: # MERGE HERE AFTER MOVE TO ADJUST PADDING AT NEW BUFFER END
19670: #
19671: ins02: movl (sp)+,r10 # restore scblk ptr
19672: movl r8,r6 # copy new buffer end
19673: movab 3+(4*0)(r6),r6 # round out
19674: bicl2 $3,r6
19675: subl2 r8,r6 # subtract to get remainder
19676: bnequ 0f # no pad if already even boundary
19677: jmp ins04
19678: 0:
19679: movl (sp),r9 # get bcblk ptr
19680: movl 4*bcbuf(r9),r9 # get bfblk ptr
19681: movab cfp$f(r9)[r8],r9# prepare to pad
19682: clrl r7 # clear wb
19683: # load loop count
19684: #
19685: # LOOP HERE TO STUFF PAD CHARACTERS
19686: #
19687: ins03: movb r7,(r9)+ # stuff zero pad
19688: sobgtr r6,ins03 # branch for more
19689: #page
19690: #
19691: # INSBF (CONTINUED)
19692: #
19693: # MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT
19694: # STRING TO THE HOLE.
19695: #
19696: ins04: movl (sp),r9 # get bcblk ptr
19697: movl 4*bcbuf(r9),r9 # get bfblk ptr
19698: movl 4*sclen(r10),r6 # get move length
19699: movab cfp$f(r10),r10 # prepare to copy from first char
19700: movl inssa,r11 # [get in scratch register]
19701: movab cfp$f(r9)[r11],r9# prepare to store in hole
19702: jsb sbmvc # copy the characters
19703: movl (sp)+,r9 # restore entry xr
19704: movl (sp)+,r10 # restore entry xl
19705: movl inssa,r6 # restore entry wa
19706: movl inssb,r7 # restore entry wb
19707: movl inssc,r8 # restore entry wc
19708: addl2 $4*2,(sp) # return to caller
19709: rsb
19710: #
19711: # HERE TO TAKE STRING CONVERT ERROR EXIT
19712: #
19713: ins05: movl (sp)+,r9 # restore entry xr
19714: movl (sp)+,r10 # restore entry xl
19715: movl inssa,r6 # restore entry wa
19716: movl inssb,r7 # restore entry wb
19717: movl inssc,r8 # restore entry wc
19718: movl (sp)+,r11 # alternate exit
19719: jmp *(r11)+
19720: #
19721: # HERE FOR INVALID OFFSET OR LENGTH
19722: #
19723: ins06: movl (sp)+,r9 # restore entry xr
19724: movl (sp)+,r10 # restore entry xl
19725: #
19726: # MERGE FOR LENGTH FAILURE EXIT WITH STACK SET
19727: #
19728: ins07: movl inssa,r6 # restore entry wa
19729: movl inssb,r7 # restore entry wb
19730: movl inssc,r8 # restore entry wc
19731: addl3 $4*1,(sp)+,r11 # alternate exit
19732: jmp *(r11)+
19733: #enp # end procedure insbf
19734: #page
19735: #
19736: # IOFCB -- GET INPUT/OUTPUT FCBLK POINTER
19737: #
19738: # USED BY ENDFILE, EJECT AND REWIND TO FIND THE FCBLK
19739: # (IF ANY) CORRESPONDING TO THEIR ARGUMENT.
19740: #
19741: # -(XS) ARGUMENT
19742: # JSR IOFCB CALL TO FIND FCBLK
19743: # PPM LOC ARG IS AN UNSUITABLE NAME
19744: # PPM LOC ARG IS NULL STRING
19745: # (XS) POPPED
19746: # (XL) PTR TO FILEARG1 VRBLK
19747: # (XR) ARGUMENT
19748: # (WA) FCBLK PTR OR 0
19749: # (WB) DESTROYED
19750: #
19751: .data 1
19752: iofcb_s: .long 0
19753: .text 0
19754: iofcb: movl (sp)+,iofcb_s # entry point
19755: jsb gtstg # get arg as string
19756: .long iofc2 # fail
19757: movl r9,r10 # copy string ptr
19758: jsb gtnvr # get as natural variable
19759: .long iofc3 # fail if null
19760: movl r10,r7 # copy string pointer again
19761: movl r9,r10 # copy vrblk ptr for return
19762: clrl r6 # in case no trblk found
19763: #
19764: # LOOP TO FIND FILE ARG1 TRBLK
19765: #
19766: iofc1: movl 4*vrval(r9),r9 # get possible trblk ptr
19767: cmpl (r9),$b$trt # fail if end of chain
19768: bnequ iofc2
19769: cmpl 4*trtyp(r9),$trtfc # loop if not file arg trblk
19770: bnequ iofc1
19771: movl 4*trfpt(r9),r6 # get fcblk ptr
19772: movl r7,r9 # copy arg
19773: addl3 $4*2,iofcb_s,r11 # return
19774: jmp (r11)
19775: #
19776: # FAIL RETURN
19777: #
19778: iofc2: movl iofcb_s,r11 # fail
19779: jmp *(r11)+
19780: #
19781: # NULL ARG
19782: #
19783: iofc3: addl3 $4*1,iofcb_s,r11 # null arg return
19784: jmp *(r11)+
19785: #enp # end procedure iofcb
19786: #page
19787: #
19788: # IOPPF -- PROCESS FILEARG2 FOR IOPUT
19789: #
19790: # (R$XSC) FILEARG2 PTR
19791: # JSR IOPPF CALL TO PROCESS FILEARG2
19792: # (XL) FILEARG1 PTR
19793: # (XR) FILE ARG2 PTR
19794: # -(XS)..-(XS) FIELDS EXTRACTED FROM FILEARG2
19795: # (WC) NO. OF FIELDS EXTRACTED
19796: # (WB) INPUT/OUTPUT FLAG
19797: # (WA) FCBLK PTR OR 0
19798: #
19799: .data 1
19800: ioppf_s: .long 0
19801: .text 0
19802: ioppf: movl (sp)+,ioppf_s # entry point
19803: clrl r7 # to count fields extracted
19804: #
19805: # LOOP TO EXTRACT FIELDS
19806: #
19807: iopp1: movl $iodel,r10 # get delimiter
19808: movl r10,r8 # copy it
19809: jsb xscan # get next field
19810: movl r9,-(sp) # stack it
19811: incl r7 # increment count
19812: tstl r6 # loop
19813: bnequ iopp1
19814: movl r7,r8 # count of fields
19815: movl ioptt,r7 # i/o marker
19816: movl r$iof,r6 # fcblk ptr or 0
19817: movl r$io2,r9 # file arg2 ptr
19818: movl r$io1,r10 # filearg1
19819: jmp *ioppf_s # return
19820: #enp # end procedure ioppf
19821: #page
19822: #
19823: # IOPUT -- ROUTINE USED BY INPUT AND OUTPUT
19824: #
19825: # IOPUT SETS UP INPUT/OUTPUT ASSOCIATIONS. IT BUILDS
19826: # SUCH TRACE AND FILE CONTROL BLOCKS AS ARE NECESSARY AND
19827: # CALLS SYSFC,SYSIO TO PERFORM CHECKS ON THE
19828: # ARGUMENTS AND TO OPEN THE FILES.
19829: #
19830: # +-----------+ +---------------+ +-----------+
19831: # +-.I I I I------.I =B$XRT I
19832: # I +-----------+ +---------------+ +-----------+
19833: # I / / (R$FCB) I *4 I
19834: # I / / +-----------+
19835: # I +-----------+ +---------------+ I I-
19836: # I I NAME +--.I =B$TRT I +-----------+
19837: # I / / +---------------+ I I
19838: # I (FIRST ARG) I =TRTIN/=TRTOU I +-----------+
19839: # I +---------------+ I
19840: # I I VALUE I I
19841: # I +---------------+ I
19842: # I I(TRTRF) 0 OR I--+ I
19843: # I +---------------+ I I
19844: # I I(TRFPT) 0 OR I----+ I
19845: # I +---------------+ I I I
19846: # I (I/O TRBLK) I I I
19847: # I +-----------+ I I I
19848: # I I I I I I
19849: # I +-----------+ I I I
19850: # I I I I I I
19851: # I +-----------+ +---------------+ I I I
19852: # I I +--.I =B$TRT I.-+ I I
19853: # I +-----------+ +---------------+ I I
19854: # I / / I =TRTFC I I I
19855: # I / / +---------------+ I I
19856: # I (FILEARG1 I VALUE I I I
19857: # I VRBLK) +---------------+ I I
19858: # I I(TRTRF) 0 OR I--+ I .
19859: # I +---------------+ I . +-----------+
19860: # I I(TRFPT) 0 OR I------./ FCBLK /
19861: # I +---------------+ I +-----------+
19862: # I (TRTRF) I
19863: # I I
19864: # I I
19865: # I +---------------+ I
19866: # I I =B$XRT I.-+
19867: # I +---------------+
19868: # I I *5 I
19869: # I +---------------+
19870: # +------------------I I
19871: # +---------------+ +-----------+
19872: # I(TRTRF) O OR I------.I =B$XRT I
19873: # +---------------+ +-----------+
19874: # I NAME OFFSET I I ETC I
19875: # +---------------+
19876: # (IOCHN - CHAIN OF NAME POINTERS)
19877: #page
19878: #
19879: # IOPUT (CONTINUED)
19880: #
19881: # NO ADDITIONAL TRAP BLOCKS ARE USED FOR STANDARD INPUT/OUT
19882: # FILES. OTHERWISE AN I/O TRAP BLOCK IS ATTACHED TO SECOND
19883: # ARG (FILEARG1) VRBLK. SEE DIAGRAM ABOVE FOR DETAILS OF
19884: # THE STRUCTURE BUILT.
19885: #
19886: # -(XS) 1ST ARG (VBL TO BE ASSOCIATED)
19887: # -(XS) 2ND ARG (FILE ARG1)
19888: # -(XS) 3RD ARG (FILE ARG2)
19889: # (WB) 0 FOR INPUT, 3 FOR OUTPUT ASSOC.
19890: # JSR IOPUT CALL FOR INPUT/OUTPUT ASSOCIATION
19891: # PPM LOC 3RD ARG NOT A STRING
19892: # PPM LOC 2ND ARG NOT A SUITABLE NAME
19893: # PPM LOC 1ST ARG NOT A SUITABLE NAME
19894: # PPM LOC INAPPROPRIATE FILE SPEC FOR I/O
19895: # PPM LOC I/O FILE DOES NOT EXIST
19896: # PPM LOC I/O FILE CANNOT BE READ/WRITTEN
19897: # (XS) POPPED
19898: # (XL,XR,WA,WB,WC) DESTROYED
19899: #
19900: .data 1
19901: ioput_s: .long 0
19902: .text 0
19903: ioput: movl (sp)+,ioput_s # entry point
19904: clrl r$iot # in case no trtrf block used
19905: clrl r$iof # in case no fcblk alocated
19906: movl r7,ioptt # store i/o trace type
19907: jsb xscni # prepare to scan filearg2
19908: .long iop13 # fail
19909: .long iopa0 # null file arg2
19910: #
19911: iopa0: movl r9,r$io2 # keep file arg2
19912: movl r6,r10 # copy length
19913: jsb gtstg # convert filearg1 to string
19914: .long iop14 # fail
19915: movl r9,r$io1 # keep filearg1 ptr
19916: jsb gtnvr # convert to natural variable
19917: .long iop00 # jump if null
19918: jmp iop04 # jump to process non-null args
19919: #
19920: # NULL FILEARG1
19921: #
19922: iop00: tstl r10 # skip if both args null
19923: bnequ 0f
19924: jmp iop01
19925: 0:
19926: jsb ioppf # process filearg2
19927: jsb sysfc # call for filearg2 check
19928: .long iop16 # fail
19929: jmp iop11 # complete file association
19930: #page
19931: #
19932: # IOPUT (CONTINUED)
19933: #
19934: # HERE WITH 0 OR FCBLK PTR IN (XL)
19935: #
19936: iop01: movl ioptt,r7 # get trace type
19937: movl r$iot,r9 # get 0 or trtrf ptr
19938: jsb trbld # build trblk
19939: movl r9,r8 # copy trblk pointer
19940: movl (sp)+,r9 # get variable from stack
19941: jsb gtvar # point to variable
19942: .long iop15 # fail
19943: movl r10,r$ion # save name pointer
19944: movl r10,r9 # copy name pointer
19945: addl2 r6,r9 # point to variable
19946: subl2 $4*vrval,r9 # subtract offset,merge into loop
19947: #
19948: # LOOP TO END OF TRBLK CHAIN IF ANY
19949: #
19950: iop02: movl r9,r10 # copy blk ptr
19951: movl 4*vrval(r9),r9 # load ptr to next trblk
19952: cmpl (r9),$b$trt # jump if not trapped
19953: bnequ iop03
19954: cmpl 4*trtyp(r9),ioptt# loop if not same assocn
19955: bnequ iop02
19956: movl 4*trnxt(r9),r9 # get value and delete old trblk
19957: #
19958: # IOPUT (CONTINUED)
19959: #
19960: # STORE NEW ASSOCIATION
19961: #
19962: iop03: movl r8,4*vrval(r10) # link to this trblk
19963: movl r8,r10 # copy pointer
19964: movl r9,4*trnxt(r10) # store value in trblk
19965: movl r$ion,r9 # restore possible vrblk pointer
19966: movl r6,r7 # keep offset to name
19967: jsb setvr # if vrblk, set vrget,vrsto
19968: movl r$iot,r9 # get 0 or trtrf ptr
19969: beqlu 0f # jump if trtrf block exists
19970: jmp iop19
19971: 0:
19972: addl3 $4*6,ioput_s,r11 # return to caller
19973: jmp (r11)
19974: #
19975: # NON STANDARD FILE
19976: # SEE IF AN FCBLK HAS ALREADY BEEN ALLOCATED.
19977: #
19978: iop04: clrl r6 # in case no fcblk found
19979: #page
19980: #
19981: # IOPUT (CONTINUED)
19982: #
19983: # SEARCH POSSIBLE TRBLK CHAIN TO PICK UP THE FCBLK
19984: #
19985: iop05: movl r9,r7 # remember blk ptr
19986: movl 4*vrval(r9),r9 # chain along
19987: cmpl (r9),$b$trt # jump if end of trblk chain
19988: bnequ iop06
19989: cmpl 4*trtyp(r9),$trtfc # loop if more to go
19990: bnequ iop05
19991: movl r9,r$iot # point to file arg1 trblk
19992: movl 4*trfpt(r9),r6 # get fcblk ptr from trblk
19993: #
19994: # WA = 0 OR FCBLK PTR
19995: # WB = PTR TO PRECEDING BLK TO WHICH ANY TRTRF BLOCK
19996: # FOR FILE ARG1 MUST BE CHAINED.
19997: #
19998: iop06: movl r6,r$iof # keep possible fcblk ptr
19999: movl r7,r$iop # keep preceding blk ptr
20000: jsb ioppf # process filearg2
20001: jsb sysfc # see if fcblk required
20002: .long iop16 # fail
20003: tstl r6 # skip if no new fcblk wanted
20004: bnequ 0f
20005: jmp iop12
20006: 0:
20007: cmpl r8,$num02 # jump if fcblk in dynamic
20008: blssu iop6a
20009: jsb alost # get it in static
20010: jmp iop6b # skip
20011: #
20012: # OBTAIN FCBLK IN DYNAMIC
20013: #
20014: iop6a: jsb alloc # get space for fcblk
20015: #
20016: # MERGE
20017: #
20018: iop6b: movl r9,r10 # point to fcblk
20019: movl r6,r7 # copy its length
20020: ashl $-2,r7,r7 # get count as words (sgd apr80)
20021: # loop counter
20022: #
20023: # CLEAR FCBLK
20024: #
20025: iop07: clrl (r9)+ # clear a word
20026: sobgtr r7,iop07 # loop
20027: cmpl r8,$num02 # skip if in static - dont set fields
20028: bnequ 0f
20029: jmp iop09
20030: 0:
20031: movl $b$xnt,(r10) # store xnblk code in case
20032: movl r6,4*1(r10) # store length
20033: tstl r8 # jump if xnblk wanted
20034: beqlu 0f
20035: jmp iop09
20036: 0:
20037: movl $b$xrt,(r10) # xrblk code requested
20038: #
20039: #page
20040: # IOPUT (CONTINUED)
20041: #
20042: # COMPLETE FCBLK INITIALISATION
20043: #
20044: iop09: movl r$iot,r9 # get possible trblk ptr
20045: movl r10,r$iof # store fcblk ptr
20046: tstl r9 # jump if trblk already found
20047: bnequ iop10
20048: #
20049: # A NEW TRBLK IS NEEDED
20050: #
20051: movl $trtfc,r7 # trtyp for fcblk trap blk
20052: jsb trbld # make the block
20053: movl r9,r$iot # copy trtrf ptr
20054: movl r$iop,r10 # point to preceding blk
20055: movl 4*vrval(r10),4*vrval(r9) # copy value field to trblk
20056: movl r9,4*vrval(r10) # link new trblk into chain
20057: movl r10,r9 # point to predecessor blk
20058: jsb setvr # set trace intercepts
20059: movl 4*vrval(r9),r9 # recover trblk ptr
20060: #
20061: # XR IS PTR TO TRBLK, XL IS FCBLK PTR OR 0
20062: #
20063: iop10: movl r$iof,4*trfpt(r9)# store fcblk ptr
20064: #
20065: # CALL SYSIO TO COMPLETE FILE ACCESSING
20066: #
20067: iop11: movl r$iof,r6 # copy fcblk ptr or 0
20068: movl ioptt,r7 # get input/output flag
20069: movl r$io2,r9 # get file arg2
20070: movl r$io1,r10 # get file arg1
20071: jsb sysio # associate to the file
20072: .long iop17 # fail
20073: .long iop18 # fail
20074: tstl r$iot # not std input if non-null trtrf blk
20075: beqlu 0f
20076: jmp iop01
20077: 0:
20078: tstl ioptt # jump if output
20079: beqlu 0f
20080: jmp iop01
20081: 0:
20082: tstl r8 # no change to standard read length
20083: bnequ 0f
20084: jmp iop01
20085: 0:
20086: movl r8,cswin # store new read length for std file
20087: jmp iop01 # merge to finish the task
20088: #
20089: # SYSFC MAY HAVE RETURNED A POINTER TO A PRIVATE FCBLK
20090: #
20091: iop12: tstl r10 # jump if private fcblk
20092: beqlu 0f
20093: jmp iop09
20094: 0:
20095: jmp iop11 # finish the association
20096: #
20097: # FAILURE RETURNS
20098: #
20099: iop13: movl ioput_s,r11 # 3rd arg not a string
20100: jmp *(r11)+
20101: iop14: addl3 $4*1,ioput_s,r11 # 2nd arg unsuitable
20102: jmp *(r11)+
20103: iop15: addl3 $4*2,ioput_s,r11 # 1st arg unsuitable
20104: jmp *(r11)+
20105: iop16: addl3 $4*3,ioput_s,r11 # file spec wrong
20106: jmp *(r11)+
20107: iop17: addl3 $4*4,ioput_s,r11 # i/o file does not exist
20108: jmp *(r11)+
20109: iop18: addl3 $4*5,ioput_s,r11 # i/o file cannot be read/written
20110: jmp *(r11)+
20111: #page
20112: #
20113: # IOPUT (CONTINUED)
20114: #
20115: # ADD TO IOCHN CHAIN OF ASSSOCIATED VARIABLES UNLESS ALREAD
20116: # PRESENT.
20117: #
20118: iop19: movl r$ion,r8 # wc = name base, wb = name offset
20119: #
20120: # SEARCH LOOP
20121: #
20122: iop20: movl 4*trtrf(r9),r9 # next link of chain
20123: beqlu iop21 # not found
20124: cmpl r8,4*ionmb(r9) # no match
20125: bnequ iop20
20126: cmpl r7,4*ionmo(r9) # exit if matched
20127: beqlu iop22
20128: jmp iop20 # loop
20129: #
20130: # NOT FOUND
20131: #
20132: iop21: movl $4*num05,r6 # space needed
20133: jsb alloc # get it
20134: movl $b$xrt,(r9) # store xrblk code
20135: movl r6,4*1(r9) # store length
20136: movl r8,4*ionmb(r9) # store name base
20137: movl r7,4*ionmo(r9) # store name offset
20138: movl r$iot,r10 # point to trtrf blk
20139: movl 4*trtrf(r10),r6 # get ptr field contents
20140: movl r9,4*trtrf(r10) # store ptr to new block
20141: movl r6,4*trtrf(r9) # complete the linking
20142: #
20143: # INSERT FCBLK ON FCBLK CHAIN FOR SYSEJ, SYSXI
20144: #
20145: iop22: tstl r$iof # skip if no fcblk
20146: beqlu iop25
20147: movl r$fcb,r10 # ptr to head of existing chain
20148: #
20149: # SEE IF FCBLK ALREADY ON CHAIN
20150: #
20151: iop23: tstl r10 # not on if end of chain
20152: beqlu iop24
20153: cmpl 4*3(r10),r$iof # dont duplicate if find it
20154: beqlu iop25
20155: movl 4*2(r10),r10 # get next link
20156: jmp iop23 # loop
20157: #
20158: # NOT FOUND SO ADD AN ENTRY FOR THIS FCBLK
20159: #
20160: iop24: movl $4*num04,r6 # space needed
20161: jsb alloc # get it
20162: movl $b$xrt,(r9) # store block code
20163: movl r6,4*1(r9) # store length
20164: movl r$fcb,4*2(r9) # store previous link in this node
20165: movl r$iof,4*3(r9) # store fcblk ptr
20166: movl r9,r$fcb # insert node into fcblk chain
20167: #
20168: # RETURN
20169: #
20170: iop25: addl3 $4*6,ioput_s,r11 # return to caller
20171: jmp (r11)
20172: #enp # end procedure ioput
20173: #page
20174: #
20175: # KTREX -- EXECUTE KEYWORD TRACE
20176: #
20177: # KTREX IS USED TO EXECUTE A POSSIBLE KEYWORD TRACE. IT
20178: # INCLUDES THE TEST ON TRACE AND TESTS FOR TRACE ACTIVE.
20179: #
20180: # (XL) PTR TO TRBLK (OR 0 IF UNTRACED)
20181: # JSR KTREX CALL TO EXECUTE KEYWORD TRACE
20182: # (XL,WA,WB,WC) DESTROYED
20183: # (RA) DESTROYED
20184: #
20185: ktrex: #prc # entry point (recursive)
20186: tstl r10 # immediate exit if keyword untraced
20187: beqlu ktrx3
20188: tstl kvtra # immediate exit if trace = 0
20189: beqlu ktrx3
20190: decl kvtra # else decrement trace
20191: movl r9,-(sp) # save xr
20192: movl r10,r9 # copy trblk pointer
20193: movl 4*trkvr(r9),r10 # load vrblk pointer (nmbas)
20194: movl $4*vrval,r6 # set name offset
20195: tstl 4*trfnc(r9) # jump if print trace
20196: beqlu ktrx1
20197: jsb trxeq # else execute full trace
20198: jmp ktrx2 # and jump to exit
20199: #
20200: # HERE FOR PRINT TRACE
20201: #
20202: ktrx1: movl r10,-(sp) # stack vrblk ptr for kwnam
20203: movl r6,-(sp) # stack offset for kwnam
20204: jsb prtsn # print statement number
20205: movl $ch$am,r6 # load ampersand
20206: jsb prtch # print ampersand
20207: jsb prtnm # print keyword name
20208: movl $tmbeb,r9 # point to blank-equal-blank
20209: jsb prtst # print blank-equal-blank
20210: jsb kwnam # get keyword pseudo-variable name
20211: movl r9,dnamp # reset ptr to delete kvblk
20212: jsb acess # get keyword value
20213: .long invalid$ # failure is impossible
20214: jsb prtvl # print keyword value
20215: jsb prtnl # terminate print line
20216: #
20217: # HERE TO EXIT AFTER COMPLETING TRACE
20218: #
20219: ktrx2: movl (sp)+,r9 # restore entry xr
20220: #
20221: # MERGE HERE TO EXIT IF NO TRACE REQUIRED
20222: #
20223: ktrx3: rsb # return to ktrex caller
20224: #enp # end procedure ktrex
20225: #page
20226: #
20227: # KWNAM -- GET PSEUDO-VARIABLE NAME FOR KEYWORD
20228: #
20229: # 1(XS) NAME BASE FOR VRBLK
20230: # 0(XS) OFFSET (SHOULD BE *VRVAL)
20231: # JSR KWNAM CALL TO GET PSEUDO-VARIABLE NAME
20232: # (XS) POPPED TWICE
20233: # (XL,WA) RESULTING PSEUDO-VARIABLE NAME
20234: # (XR,WA,WB) DESTROYED
20235: #
20236: .data 1
20237: kwnam_s: .long 0
20238: .text 0
20239: kwnam: movl (sp)+,kwnam_s # entry point
20240: addl2 $4,sp # ignore name offset
20241: movl (sp)+,r9 # load name base
20242: cmpl r9,state # jump if not natural variable name
20243: bgequ kwnm1
20244: tstl 4*vrlen(r9) # error if not system variable
20245: bnequ kwnm1
20246: movl 4*vrsvp(r9),r9 # else point to svblk
20247: movl 4*svbit(r9),r6 # load bit mask
20248: mcoml btknm,r11 # and with keyword bit
20249: bicl2 r11,r6
20250: beqlu kwnm1 # error if no keyword association
20251: movl 4*svlen(r9),r6 # else load name length in characters
20252: movab 3+(4*svchs)(r6),r6 # compute offset to field we want
20253: bicl2 $3,r6
20254: addl2 r6,r9 # point to svknm field
20255: movl (r9),r7 # load svknm value
20256: movl $4*kvsi$,r6 # set size of kvblk
20257: jsb alloc # allocate kvblk
20258: movl $b$kvt,(r9) # store type word
20259: movl r7,4*kvnum(r9) # store keyword number
20260: movl $trbkv,4*kvvar(r9) # set dummy trblk pointer
20261: movl r9,r10 # copy kvblk pointer
20262: movl $4*kvvar,r6 # set proper offset
20263: jmp *kwnam_s # return to kvnam caller
20264: #
20265: # HERE IF NOT KEYWORD NAME
20266: #
20267: kwnm1: jmp er_251 # keyword operand is not name of defined keyword
20268: #enp # end procedure kwnam
20269: #page
20270: #
20271: # LCOMP-- COMPARE TWO STRINGS LEXICALLY
20272: #
20273: # 1(XS) FIRST ARGUMENT
20274: # 0(XS) SECOND ARGUMENT
20275: # JSR LCOMP CALL TO COMPARE ARUMENTS
20276: # PPM LOC TRANSFER LOC FOR ARG1 NOT STRING
20277: # PPM LOC TRANSFER LOC FOR ARG2 NOT STRING
20278: # PPM LOC TRANSFER LOC IF ARG1 LLT ARG2
20279: # PPM LOC TRANSFER LOC IF ARG1 LEQ ARG2
20280: # PPM LOC TRANSFER LOC IF ARG1 LGT ARG2
20281: # (THE NORMAL RETURN IS NEVER TAKEN)
20282: # (XS) POPPED TWICE
20283: # (XR,XL) DESTROYED
20284: # (WA,WB,WC,RA) DESTROYED
20285: #
20286: .data 1
20287: lcomp_s: .long 0
20288: .text 0
20289: lcomp: movl (sp)+,lcomp_s # entry point
20290: jsb gtstg # convert second arg to string
20291: .long lcmp6 # jump if second arg not string
20292: movl r9,r10 # else save pointer
20293: movl r6,r7 # and length
20294: jsb gtstg # convert first argument to string
20295: .long lcmp5 # jump if not string
20296: movl r6,r8 # save arg 1 length
20297: movab cfp$f(r9),r9 # point to chars of arg 1
20298: movab cfp$f(r10),r10 # point to chars of arg 2
20299: cmpl r6,r7 # jump if arg 1 length is smaller
20300: blequ lcmp1
20301: movl r7,r6 # else set arg 2 length as smaller
20302: #
20303: # HERE WITH SMALLER LENGTH IN (WA)
20304: #
20305: lcmp1: jsb sbcmc # compare strings, jump if unequal
20306: .long lcmp4
20307: .long lcmp3
20308: cmpl r7,r8 # if equal, jump if lengths unequal
20309: bnequ lcmp2
20310: addl3 $4*3,lcomp_s,r11 # else identical strings, leq exit
20311: jmp *(r11)+
20312: #page
20313: #
20314: # LCOMP (CONTINUED)
20315: #
20316: # HERE IF INITIAL STRINGS IDENTICAL, BUT LENGTHS UNEQUAL
20317: #
20318: lcmp2: cmpl r8,r7 # jump if arg 1 length gt arg 2 leng
20319: bgequ lcmp4
20320: #
20321: # HERE IF FIRST ARG LLT SECOND ARG
20322: #
20323: lcmp3: addl3 $4*2,lcomp_s,r11 # take llt exit
20324: jmp *(r11)+
20325: #
20326: # HERE IF FIRST ARG LGT SECOND ARG
20327: #
20328: lcmp4: addl3 $4*4,lcomp_s,r11 # take lgt exit
20329: jmp *(r11)+
20330: #
20331: # HERE IF FIRST ARG IS NOT A STRING
20332: #
20333: lcmp5: movl lcomp_s,r11 # take bad first arg exit
20334: jmp *(r11)+
20335: #
20336: # HERE FOR SECOND ARG NOT A STRING
20337: #
20338: lcmp6: addl3 $4*1,lcomp_s,r11 # take bad second arg error exit
20339: jmp *(r11)+
20340: #enp # end procedure lcomp
20341: #page
20342: #
20343: # LISTR -- LIST SOURCE LINE
20344: #
20345: # LISTR IS USED TO LIST A SOURCE LINE DURING THE INITIAL
20346: # COMPILATION. IT IS CALLED FROM SCANE AND SCANL.
20347: #
20348: # JSR LISTR CALL TO LIST LINE
20349: # (XR,XL,WA,WB,WC) DESTROYED
20350: #
20351: # GLOBAL LOCATIONS USED BY LISTR
20352: #
20353: # ERLST IF LISTING ON ACCOUNT OF AN ERROR
20354: #
20355: # LSTLC COUNT LINES ON CURRENT PAGE
20356: #
20357: # LSTNP MAX NUMBER OF LINES/PAGE
20358: #
20359: # LSTPF SET NON-ZERO IF THE CURRENT SOURCE
20360: # LINE HAS BEEN LISTED, ELSE ZERO.
20361: #
20362: # LSTPG COMPILER LISTING PAGE NUMBER
20363: #
20364: # LSTSN SET IF STMNT NUM TO BE LISTED
20365: #
20366: # R$CIM POINTER TO CURRENT INPUT LINE.
20367: #
20368: # R$TTL TITLE FOR SOURCE LISTING
20369: #
20370: # R$STL PTR TO SUB-TITLE STRING
20371: #
20372: # ENTRY POINT
20373: #
20374: listr: #prc # entry point
20375: tstl cnttl # jump if -title or -stitl
20376: beqlu 0f
20377: jmp list5
20378: 0:
20379: tstl lstpf # immediate exit if already listed
20380: beqlu 0f
20381: jmp list4
20382: 0:
20383: cmpl lstlc,lstnp # jump if no room
20384: blssu 0f
20385: jmp list6
20386: 0:
20387: #
20388: # HERE AFTER PRINTING TITLE (IF NEEDED)
20389: #
20390: list0: movl r$cim,r9 # load pointer to current image
20391: movab cfp$f(r9),r9 # point to characters
20392: movzbl (r9),r6 # load first character
20393: movl lstsn,r9 # load statement number
20394: beqlu list2 # jump if no statement number
20395: movl r9,r5 # else get stmnt number as integer
20396: cmpl stage,$stgic # skip if execute time
20397: bnequ list1
20398: cmpl r6,$ch$as # no stmnt number list if comment
20399: beqlu list2
20400: cmpl r6,$ch$mn # no stmnt no. if control card
20401: beqlu list2
20402: #
20403: # PRINT STATEMENT NUMBER
20404: #
20405: list1: jsb prtin # else print statement number
20406: clrl lstsn # and clear for next time in
20407: #page
20408: #
20409: # LISTR (CONTINUED)
20410: #
20411: # MERGE HERE AFTER PRINTING STATEMENT NUMBER (IF REQUIRED)
20412: #
20413: list2: movl $stnpd,profs # point past statement number
20414: movl r$cim,r9 # load pointer to current image
20415: jsb prtst # print it
20416: incl lstlc # bump line counter
20417: tstl erlst # jump if error copy to int.ch.
20418: bnequ list3
20419: jsb prtnl # terminate line
20420: tstl cswdb # jump if -single mode
20421: beqlu list3
20422: jsb prtnl # else add a blank line
20423: incl lstlc # and bump line counter
20424: #
20425: # HERE AFTER PRINTING SOURCE IMAGE
20426: #
20427: list3: movl sp,lstpf # set flag for line printed
20428: #
20429: # MERGE HERE TO EXIT
20430: #
20431: list4: rsb # return to listr caller
20432: #
20433: # PRINT TITLE AFTER -TITLE OR -STITL CARD
20434: #
20435: list5: clrl cnttl # clear flag
20436: #
20437: # EJECT TO NEW PAGE AND LIST TITLE
20438: #
20439: list6: jsb prtps # eject
20440: tstl prich # skip if listing to regular printer
20441: beqlu list7
20442: cmpl r$ttl,$nulls # terminal listing omits null title
20443: bnequ 0f
20444: jmp list0
20445: 0:
20446: #
20447: # LIST TITLE
20448: #
20449: list7: jsb listt # list title
20450: jmp list0 # merge
20451: #enp # end procedure listr
20452: #page
20453: #
20454: # LISTT -- LIST TITLE AND SUBTITLE
20455: #
20456: # USED DURING COMPILATION TO PRINT PAGE HEADING
20457: #
20458: # JSR LISTT CALL TO LIST TITLE
20459: # (XR,WA) DESTROYED
20460: #
20461: listt: #prc # entry point
20462: movl r$ttl,r9 # point to source listing title
20463: jsb prtst # print title
20464: movl lstpo,profs # set offset
20465: movl $lstms,r9 # set page message
20466: jsb prtst # print page message
20467: incl lstpg # bump page number
20468: movl lstpg,r5 # load page number as integer
20469: jsb prtin # print page number
20470: jsb prtnl # terminate title line
20471: addl2 $num02,lstlc # count title line and blank line
20472: #
20473: # PRINT SUB-TITLE (IF ANY)
20474: #
20475: movl r$stl,r9 # load pointer to sub-title
20476: beqlu lstt1 # jump if no sub-title
20477: jsb prtst # else print sub-title
20478: jsb prtnl # terminate line
20479: incl lstlc # bump line count
20480: #
20481: # RETURN POINT
20482: #
20483: lstt1: jsb prtnl # print a blank line
20484: rsb # return to caller
20485: #enp # end procedure listt
20486: #page
20487: #
20488: # NEXTS -- ACQUIRE NEXT SOURCE IMAGE
20489: #
20490: # NEXTS IS USED TO ACQUIRE THE NEXT SOURCE IMAGE AT COMPILE
20491: # TIME. IT ASSUMES THAT A PRIOR CALL TO READR HAS INPUT
20492: # A LINE IMAGE (SEE PROCEDURE READR). BEFORE THE CURRENT
20493: # IMAGE IS FINALLY LOST IT MAY BE LISTED HERE.
20494: #
20495: # JSR NEXTS CALL TO ACQUIRE NEXT INPUT LINE
20496: # (XR,XL,WA,WB,WC) DESTROYED
20497: #
20498: # GLOBAL VALUES AFFECTED
20499: #
20500: # R$CNI ON INPUT, NEXT IMAGE. ON
20501: # EXIT RESET TO ZERO
20502: #
20503: # R$CIM ON EXIT, SET TO POINT TO IMAGE
20504: #
20505: # SCNIL INPUT IMAGE LENGTH ON EXIT
20506: #
20507: # SCNSE RESET TO ZERO ON EXIT
20508: #
20509: # LSTPF SET ON EXIT IF LINE IS LISTED
20510: #
20511: nexts: #prc # entry point
20512: tstl cswls # jump if -nolist
20513: beqlu nxts2
20514: movl r$cim,r9 # point to image
20515: beqlu nxts2 # jump if no image
20516: movab cfp$f(r9),r9 # get char ptr
20517: movzbl (r9),r6 # get first char
20518: cmpl r6,$ch$mn # jump if not ctrl card
20519: bnequ nxts1
20520: tstl cswpr # jump if -noprint
20521: beqlu nxts2
20522: #
20523: # HERE TO CALL LISTER
20524: #
20525: nxts1: jsb listr # list line
20526: #
20527: # HERE AFTER POSSIBLE LISTING
20528: #
20529: nxts2: movl r$cni,r9 # point to next image
20530: movl r9,r$cim # set as next image
20531: clrl r$cni # clear next image pointer
20532: movl 4*sclen(r9),r6 # get input image length
20533: movl cswin,r7 # get max allowable length
20534: cmpl r6,r7 # skip if not too long
20535: blequ nxts3
20536: movl r7,r6 # else truncate
20537: #
20538: # HERE WITH LENGTH IN (WA)
20539: #
20540: nxts3: movl r6,scnil # use as record length
20541: clrl scnse # reset scnse
20542: clrl lstpf # set line not listed yet
20543: rsb # return to nexts caller
20544: #enp # end procedure nexts
20545: #page
20546: #
20547: # PATIN -- PATTERN CONSTRUCTION FOR LEN,POS,RPOS,TAB,RTAB
20548: #
20549: # THESE PATTERN TYPES ALL GENERATE A SIMILAR NODE TYPE. SO
20550: # THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION
20551: # FOR ACTUAL ENTRY POINTS FOR THESE FIVE FUNCTIONS.
20552: #
20553: # (WA) PCODE FOR EXPRESSION ARG CASE
20554: # (WB) PCODE FOR INTEGER ARG CASE
20555: # JSR PATIN CALL TO BUILD PATTERN NODE
20556: # PPM LOC TRANSFER LOC FOR NOT INTEGER OR EXP
20557: # PPM LOC TRANSFER LOC FOR INT OUT OF RANGE
20558: # (XR) POINTER TO CONSTRUCTED NODE
20559: # (XL,WA,WB,WC,IA) DESTROYED
20560: #
20561: .data 1
20562: patin_s: .long 0
20563: .text 0
20564: patin: movl (sp)+,patin_s # entry point
20565: movl r6,r10 # preserve expression arg pcode
20566: jsb gtsmi # try to convert arg as small integer
20567: .long ptin2 # jump if not integer
20568: .long ptin3 # jump if out of range
20569: #
20570: # COMMON SUCCESSFUL EXIT POINT
20571: #
20572: ptin1: jsb pbild # build pattern node
20573: addl3 $4*2,patin_s,r11 # return to caller
20574: jmp (r11)
20575: #
20576: # HERE IF ARGUMENT IS NOT AN INTEGER
20577: #
20578: ptin2: movl r10,r7 # copy expr arg case pcode
20579: cmpl (r9),$b$e$$ # all ok if expression arg
20580: blequ ptin1
20581: movl patin_s,r11 # else take error exit for wrong type
20582: jmp *(r11)+
20583: #
20584: # HERE FOR ERROR OF OUT OF RANGE INTEGER ARGUMENT
20585: #
20586: ptin3: addl3 $4*1,patin_s,r11 # take out-of-range error exit
20587: jmp *(r11)+
20588: #enp # end procedure patin
20589: #page
20590: #
20591: # PATST -- PATTERN CONSTRUCTION FOR ANY,NOTANY,
20592: # BREAK,SPAN AND BREAKX PATTERN FUNCTIONS.
20593: #
20594: # THESE PATTERN FUNCTIONS BUILD SIMILAR TYPES OF NODES AND
20595: # THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION
20596: # FOR ACTUAL ENTRY POINTS FOR THESE FIVE PATTERN FUNCTIONS.
20597: #
20598: # 0(XS) STRING ARGUMENT
20599: # (WB) PCODE FOR ONE CHAR ARGUMENT
20600: # (XL) PCODE FOR MULTI-CHAR ARGUMENT
20601: # (WC) PCODE FOR EXPRESSION ARGUMENT
20602: # JSR PATST CALL TO BUILD NODE
20603: # PPM LOC TRANSFER LOC IF NOT STRING OR EXPR
20604: # (XS) POPPED PAST STRING ARGUMENT
20605: # (XR) POINTER TO CONSTRUCTED NODE
20606: # (XL) DESTROYED
20607: # (WA,WB,WC,RA) DESTROYED
20608: #
20609: # NOTE THAT THERE IS A SPECIAL CALL TO PATST IN THE EVALS
20610: # PROCEDURE WITH A SLIGHTLY DIFFERENT FORM. SEE EVALS
20611: # FOR DETAILS OF THE FORM OF THIS CALL.
20612: #
20613: .data 1
20614: patst_s: .long 0
20615: .text 0
20616: patst: movl (sp)+,patst_s # entry point
20617: jsb gtstg # convert argument as string
20618: .long pats7 # jump if not string
20619: cmpl r6,$num01 # jump if not one char string
20620: bnequ pats2
20621: #
20622: # HERE FOR ONE CHAR STRING CASE
20623: #
20624: tstl r7 # treat as multi-char if evals call
20625: beqlu pats2
20626: movab cfp$f(r9),r9 # point to character
20627: movzbl (r9),r9 # load character
20628: #
20629: # COMMON EXIT POINT AFTER SUCCESSFUL CONSTRUCTION
20630: #
20631: pats1: jsb pbild # call routine to build node
20632: addl3 $4*1,patst_s,r11 # return to patst caller
20633: jmp (r11)
20634: #page
20635: #
20636: # PATST (CONTINUED)
20637: #
20638: # HERE FOR MULTI-CHARACTER STRING CASE
20639: #
20640: pats2: movl r10,-(sp) # save multi-char pcode
20641: movl r9,-(sp) # save string pointer
20642: movl ctmsk,r8 # load current mask bit
20643: ashl $1,r8,r8 # shift to next position
20644: tstl r8 # skip if position left in this tbl
20645: bnequ pats4
20646: #
20647: # HERE WE MUST ALLOCATE A NEW CHARACTER TABLE
20648: #
20649: movl $4*ctsi$,r6 # set size of ctblk
20650: jsb alloc # allocate ctblk
20651: movl r9,r$ctp # store ptr to new ctblk
20652: movl $b$ctt,(r9)+ # store type code, bump ptr
20653: movl $cfp$a,r7 # set number of words to clear
20654: movl bits0,r8 # load all zero bits
20655: #
20656: # LOOP TO CLEAR ALL BITS IN TABLE TO ZEROS
20657: #
20658: pats3: movl r8,(r9)+ # move word of zero bits
20659: sobgtr r7,pats3 # loop till all cleared
20660: movl bits1,r8 # set initial bit position
20661: #
20662: # MERGE HERE WITH BIT POSITION AVAILABLE
20663: #
20664: pats4: movl r8,ctmsk # save parm2 (new bit position)
20665: movl (sp)+,r10 # restore pointer to argument string
20666: movl 4*sclen(r10),r7 # load string length
20667: beqlu pats6 # jump if null string case
20668: # else set loop counter
20669: movab cfp$f(r10),r10 # point to characters in argument
20670: #page
20671: #
20672: # PATST (CONTINUED)
20673: #
20674: # LOOP TO SET BITS IN COLUMN OF TABLE
20675: #
20676: pats5: movzbl (r10)+,r6 # load next character
20677: moval 0[r6],r6 # convert to byte offset
20678: movl r$ctp,r9 # point to ctblk
20679: addl2 r6,r9 # point to ctblk entry
20680: movl r8,r6 # copy bit mask
20681: bisl2 4*ctchs(r9),r6 # or in bits already set
20682: movl r6,4*ctchs(r9) # store resulting bit string
20683: sobgtr r7,pats5 # loop till all bits set
20684: #
20685: # COMPLETE PROCESSING FOR MUTI-CHAR STRING CASE
20686: #
20687: pats6: movl r$ctp,r9 # load ctblk ptr as parm1 for pbild
20688: clrl r10 # clear garbage ptr in xl
20689: movl (sp)+,r7 # load pcode for multi-char str case
20690: jmp pats1 # back to exit (wc=bitstring=parm2)
20691: #
20692: # HERE IF ARGUMENT IS NOT A STRING
20693: #
20694: # NOTE THAT THE CALL FROM EVALS CANNOT PASS AN EXPRESSION
20695: # SINCE EVALP ALWAYS REEVALUATES EXPRESSIONS.
20696: #
20697: pats7: movl r8,r7 # set pcode for expression argument
20698: cmpl (r9),$b$e$$ # jump to exit if expression arg
20699: bgtru 0f
20700: jmp pats1
20701: 0:
20702: movl patst_s,r11 # else take wrong type error exit
20703: jmp *(r11)+
20704: #enp # end procedure patst
20705: #page
20706: #
20707: # PBILD -- BUILD PATTERN NODE
20708: #
20709: # (XR) PARM1 (ONLY IF REQUIRED)
20710: # (WB) PCODE FOR NODE
20711: # (WC) PARM2 (ONLY IF REQUIRED)
20712: # JSR PBILD CALL TO BUILD NODE
20713: # (XR) POINTER TO CONSTRUCTED NODE
20714: # (WA) DESTROYED
20715: #
20716: pbild: #prc # entry point
20717: movl r9,-(sp) # stack possible parm1
20718: movl r7,r9 # copy pcode
20719: movzwl -2(r9),r9 # load entry point id (bl$px)
20720: cmpl r9,$bl$p1 # jump if one parameter
20721: beqlu pbld1
20722: cmpl r9,$bl$p0 # jump if no parameters
20723: beqlu pbld3
20724: #
20725: # HERE FOR TWO PARAMETER CASE
20726: #
20727: movl $4*pcsi$,r6 # set size of p2blk
20728: jsb alloc # allocate block
20729: movl r8,4*parm2(r9) # store second parameter
20730: jmp pbld2 # merge with one parm case
20731: #
20732: # HERE FOR ONE PARAMETER CASE
20733: #
20734: pbld1: movl $4*pbsi$,r6 # set size of p1blk
20735: jsb alloc # allocate node
20736: #
20737: # MERGE HERE FROM TWO PARM CASE
20738: #
20739: pbld2: movl (sp),4*parm1(r9)# store first parameter
20740: jmp pbld4 # merge with no parameter case
20741: #
20742: # HERE FOR CASE OF NO PARAMETERS
20743: #
20744: pbld3: movl $4*pasi$,r6 # set size of p0blk
20745: jsb alloc # allocate node
20746: #
20747: # MERGE HERE FROM OTHER CASES
20748: #
20749: pbld4: movl r7,(r9) # store pcode
20750: addl2 $4,sp # pop first parameter
20751: movl $ndnth,4*pthen(r9) # set nothen successor pointer
20752: rsb # return to pbild caller
20753: #enp # end procedure pbild
20754: #page
20755: #
20756: # PCONC -- CONCATENATE TWO PATTERNS
20757: #
20758: # (XL) PTR TO RIGHT PATTERN
20759: # (XR) PTR TO LEFT PATTERN
20760: # JSR PCONC CALL TO CONCATENATE PATTERNS
20761: # (XR) PTR TO CONCATENATED PATTERN
20762: # (XL,WA,WB,WC) DESTROYED
20763: #
20764: #
20765: # TO CONCATENATE TWO PATTERNS, ALL SUCCESSORS IN THE LEFT
20766: # PATTERN WHICH POINT TO THE NOTHEN NODE MUST BE CHANGED TO
20767: # POINT TO THE RIGHT PATTERN. HOWEVER, THIS MODIFICATION
20768: # MUST BE PERFORMED ON A COPY OF THE LEFT ARGUMENT RATHER
20769: # THAN THE LEFT ARGUMENT ITSELF, SINCE THE LEFT ARGUMENT
20770: # MAY BE POINTED TO BY SOME OTHER VARIABLE VALUE.
20771: #
20772: # ACCORDINGLY, IT IS NECESSARY TO COPY THE LEFT ARGUMENT.
20773: # THIS IS NOT A TRIVIAL PROCESS SINCE WE MUST AVOID COPYING
20774: # NODES MORE THAN ONCE AND THE PATTERN IS A GRAPH STRUCTURE
20775: # THE FOLLOWING ALGORITHM IS EMPLOYED.
20776: #
20777: # THE STACK IS USED TO STORE A LIST OF NODES WHICH
20778: # HAVE ALREADY BEEN COPIED. THE FORMAT OF THE ENTRIES ON
20779: # THIS LIST CONSISTS OF A TWO WORD BLOCK. THE FIRST WORD
20780: # IS THE OLD ADDRESS AND THE SECOND WORD IS THE ADDRESS
20781: # OF THE COPY. THIS LIST IS SEARCHED BY THE PCOPY
20782: # ROUTINE TO AVOID MAKING DUPLICATE COPIES. A TRICK IS
20783: # USED TO ACCOMPLISH THE CONCATENATION AT THE SAME TIME.
20784: # A SPECIAL ENTRY IS MADE TO START WITH ON THE STACK. THIS
20785: # ENTRY RECORDS THAT THE NOTHEN NODE HAS BEEN COPIED
20786: # ALREADY AND THE ADDRESS OF ITS COPY IS THE RIGHT PATTERN.
20787: # THIS AUTOMATICALLY PERFORMS THE CORRECT REPLACEMENTS.
20788: #
20789: pconc: #prc # entry point
20790: clrl -(sp) # make room for one entry at bottom
20791: movl sp,r8 # store pointer to start of list
20792: movl $ndnth,-(sp) # stack nothen node as old node
20793: movl r10,-(sp) # store right arg as copy of nothen
20794: movl sp,r10 # initialize pointer to stack entries
20795: jsb pcopy # copy first node of left arg
20796: movl r6,4*2(r10) # store as result under list
20797: #page
20798: #
20799: # PCONC (CONTINUED)
20800: #
20801: # THE FOLLOWING LOOP SCANS ENTRIES IN THE LIST AND MAKES
20802: # SURE THAT THEIR SUCCESSORS HAVE BEEN COPIED.
20803: #
20804: pcnc1: cmpl r10,sp # jump if all entries processed
20805: beqlu pcnc2
20806: movl -(r10),r9 # else load next old address
20807: movl 4*pthen(r9),r9 # load pointer to successor
20808: jsb pcopy # copy successor node
20809: movl -(r10),r9 # load pointer to new node (copy)
20810: movl r6,4*pthen(r9) # store ptr to new successor
20811: #
20812: # NOW CHECK FOR SPECIAL CASE OF ALTERNATION NODE WHERE
20813: # PARM1 POINTS TO A NODE AND MUST BE COPIED LIKE PTHEN.
20814: #
20815: cmpl (r9),$p$alt # loop back if not
20816: bnequ pcnc1
20817: movl 4*parm1(r9),r9 # else load pointer to alternative
20818: jsb pcopy # copy it
20819: movl (r10),r9 # restore ptr to new node
20820: movl r6,4*parm1(r9) # store ptr to copied alternative
20821: jmp pcnc1 # loop back for next entry
20822: #
20823: # HERE AT END OF COPY PROCESS
20824: #
20825: pcnc2: movl r8,sp # restore stack pointer
20826: movl (sp)+,r9 # load pointer to copy
20827: rsb # return to pconc caller
20828: #enp # end procedure pconc
20829: #page
20830: #
20831: # PCOPY -- COPY A PATTERN NODE
20832: #
20833: # PCOPY IS CALLED FROM THE PCONC PROCEDURE TO COPY A SINGLE
20834: # PATTERN NODE. THE COPY IS ONLY CARRIED OUT IF THE NODE
20835: # HAS NOT BEEN COPIED ALREADY.
20836: #
20837: # (XR) POINTER TO NODE TO BE COPIED
20838: # (XT) PTR TO CURRENT LOC IN COPY LIST
20839: # (WC) POINTER TO LIST OF COPIED NODES
20840: # JSR PCOPY CALL TO COPY A NODE
20841: # (WA) POINTER TO COPY
20842: # (WB,XR) DESTROYED
20843: #
20844: .data 1
20845: pcopy_s: .long 0
20846: .text 0
20847: pcopy: movl (sp)+,pcopy_s # entry point
20848: movl r10,r7 # save xt
20849: movl r8,r10 # point to start of list
20850: #
20851: # LOOP TO SEARCH LIST OF NODES COPIED ALREADY
20852: #
20853: pcop1: subl2 $4,r10 # point to next entry on list
20854: cmpl r9,(r10) # jump if match
20855: beqlu pcop2
20856: subl2 $4,r10 # else skip over copied address
20857: cmpl r10,sp # loop back if more to test
20858: bnequ pcop1
20859: #
20860: # HERE IF NOT IN LIST, PERFORM COPY
20861: #
20862: movl (r9),r6 # load first word of block
20863: jsb blkln # get length of block
20864: movl r9,r10 # save pointer to old node
20865: jsb alloc # allocate space for copy
20866: movl r10,-(sp) # store old address on list
20867: movl r9,-(sp) # store new address on list
20868: jsb sbchk # check for stack overflow
20869: jsb sbmvw # move words from old block to copy
20870: movl (sp),r6 # load pointer to copy
20871: jmp pcop3 # jump to exit
20872: #
20873: # HERE IF WE FIND ENTRY IN LIST
20874: #
20875: pcop2: movl -(r10),r6 # load address of copy from list
20876: #
20877: # COMMON EXIT POINT
20878: #
20879: pcop3: movl r7,r10 # restore xt
20880: jmp *pcopy_s # return to pcopy caller
20881: #enp # end procedure pcopy
20882: #page
20883: #
20884: # PRFLR -- PRINT PROFILE
20885: # PRFLR IS CALLED TO PRINT THE CONTENTS OF THE PROFILE
20886: # TABLE IN A FAIRLY READABLE TABULAR FORMAT.
20887: #
20888: # JSR PRFLR CALL TO PRINT PROFILE
20889: # (WA,IA) DESTROYED
20890: #
20891: prflr: #prc
20892: tstl pfdmp # no printing if no profiling done
20893: bnequ 0f
20894: jmp prfl4
20895: 0:
20896: movl r9,-(sp) # preserve entry xr
20897: movl r7,pfsvw # and also wb
20898: jsb prtpg # eject
20899: movl $pfms1,r9 # load msg /program profile/
20900: jsb prtst # and print it
20901: jsb prtnl # followed by newline
20902: jsb prtnl # and another
20903: movl $pfms2,r9 # point to first hdr
20904: jsb prtst # print it
20905: jsb prtnl # new line
20906: movl $pfms3,r9 # second hdr
20907: jsb prtst # print it
20908: jsb prtnl # new line
20909: jsb prtnl # and another blank line
20910: clrl r7 # initial stmt count
20911: movl pftbl,r9 # point to table origin
20912: addl2 $4*num02,r9 # bias past xnblk header (sgd07)
20913: #
20914: # LOOP HERE TO PRINT SUCCESSIVE ENTRIES
20915: #
20916: prfl1: incl r7 # bump stmt nr
20917: movl (r9),r5 # load nr of executions
20918: beql prfl3 # no printing if zero
20919: movl $pfpd1,profs # point where to print
20920: jsb prtin # and print it
20921: clrl profs # back to start of line
20922: movl r7,r5 # load stmt nr
20923: jsb prtin # print it there
20924: movl $pfpd2,profs # and pad past count
20925: movl 4*cfp$i(r9),r5 # load total exec time
20926: jsb prtin # print that too
20927: movl 4*cfp$i(r9),r5 # reload time
20928: mull2 intth,r5 # convert to microsec
20929: bvs prfl2
20930: divl2 (r9),r5 # divide by executions
20931: movl $pfpd3,profs # pad last print
20932: jsb prtin # and print mcsec/execn
20933: #
20934: # MERGE AFTER PRINTING TIME
20935: #
20936: prfl2: jsb prtnl # thats another line
20937: #
20938: # HERE TO GO TO NEXT ENTRY
20939: #
20940: prfl3: addl2 $4*pf$i2,r9 # bump index ptr (sgd07)
20941: cmpl r7,pfnte # loop if more stmts
20942: blssu prfl1
20943: movl (sp)+,r9 # restore callers xr
20944: movl pfsvw,r7 # and wb too
20945: #
20946: # HERE TO EXIT
20947: #
20948: prfl4: rsb # return
20949: #enp # end of prflr
20950: #page
20951: #
20952: # PRFLU -- UPDATE AN ENTRY IN THE PROFILE TABLE
20953: #
20954: # ON ENTRY, KVSTN CONTAINS NR OF STMT TO PROFILE
20955: #
20956: # JSR PRFLU CALL TO UPDATE ENTRY
20957: # (IA) DESTROYED
20958: #
20959: prflu: #prc
20960: tstl pffnc # skip if just entered function
20961: beqlu 0f
20962: jmp pflu4
20963: 0:
20964: movl r9,-(sp) # preserve entry xr
20965: movl r6,pfsvw # save wa (sgd07)
20966: tstl pftbl # branch if table allocated
20967: bnequ pflu2
20968: #
20969: # HERE IF SPACE FOR PROFILE TABLE NOT YET ALLOCATED.
20970: # CALCULATE SIZE NEEDED, ALLOCATE A STATIC XNBLK, AND
20971: # INITIALIZE IT ALL TO ZERO.
20972: # THE TIME TAKEN FOR THIS WILL BE ATTRIBUTED TO THE CURRENT
20973: # STATEMENT (ASSIGNMENT TO KEYWD PROFILE), BUT SINCE THE
20974: # TIMING FOR THIS STATEMENT IS UP THE POLE ANYWAY, THIS
20975: # DOESNT REALLY MATTER...
20976: #
20977: subl2 $num01,pfnte # adjust for extra count (sgd07)
20978: movl pfi2a,r5 # convrt entry size to int
20979: movl r5,pfste # and store safely for later
20980: movl pfnte,r5 # load table length as integer
20981: mull2 pfste,r5 # multiply by entry size
20982: movl r5,r6 # get back address-style
20983: addl2 $num02,r6 # add on 2 word overhead
20984: moval 0[r6],r6 # convert the whole lot to bytes
20985: jsb alost # gimme the space
20986: movl r9,pftbl # save block pointer
20987: movl $b$xnt,(r9)+ # put block type and ...
20988: movl r6,(r9)+ # ... length into header
20989: movl r5,r6 # get back nr of wds in data area
20990: # load the counter
20991: #
20992: # LOOP HERE TO ZERO THE BLOCK DATA
20993: #
20994: pflu1: clrl (r9)+ # blank a word
20995: sobgtr r6,pflu1 # and alllllll the rest
20996: #
20997: # END OF ALLOCATION. MERGE BACK INTO ROUTINE
20998: #
20999: pflu2: movl kvstn,r5 # load nr of stmt just ended
21000: subl2 intv1,r5 # make into index offset
21001: mull2 pfste,r5 # make offset of table entry
21002: movl r5,r6 # convert to address
21003: moval 0[r6],r6 # get as baus
21004: addl2 $4*num02,r6 # offset includes table header
21005: movl pftbl,r9 # get table start
21006: cmpl r6,4*num01(r9) # if out of table, skip it
21007: bgequ pflu3
21008: addl2 r6,r9 # else point to entry
21009: movl (r9),r5 # get nr of executions so far
21010: addl2 intv1,r5 # nudge up one
21011: movl r5,(r9) # and put back
21012: jsb systm # get time now
21013: movl r5,pfetm # stash ending time
21014: subl2 pfstm,r5 # subtract start time
21015: addl2 4*cfp$i(r9),r5 # add cumulative time so far
21016: movl r5,4*cfp$i(r9) # and put back new total
21017: movl pfetm,r5 # load end time of this stmt ...
21018: movl r5,pfstm # ... which is start time of next
21019: #
21020: # MERGE HERE TO EXIT
21021: #
21022: pflu3: movl (sp)+,r9 # restore callers xr
21023: movl pfsvw,r6 # restore saved reg
21024: rsb # and return
21025: #
21026: # HERE IF PROFILE IS SUPPRESSED BECAUSE A PROGRAM DEFINED
21027: # FUNCTION IS ABOUT TO BE ENTERED, AND SO THE CURRENT STMT
21028: # HAS NOT YET FINISHED
21029: #
21030: pflu4: clrl pffnc # reset the condition flag
21031: rsb # and immediate return
21032: #enp # end of procedure prflu
21033: #page
21034: #
21035: # PRPAR - PROCESS PRINT PARAMETERS
21036: #
21037: # (WC) IF NONZERO ASSOCIATE TERMINAL ONLY
21038: # JSR PRPAR CALL TO PROCESS PRINT PARAMETERS
21039: # (XL,XR,WA,WB,WC) DESTROYED
21040: #
21041: # SINCE MEMORY ALLOCATION IS UNDECIDED ON INITIAL CALL,
21042: # TERMINAL CANNOT BE ASSOCIATED. THE ENTRY WITH WC NON-ZERO
21043: # IS PROVIDED SO A LATER CALL CAN BE MADE TO COMPLETE THIS.
21044: #
21045: prpar: #prc # entry point
21046: tstl r8 # jump to associate terminal
21047: beqlu 0f
21048: jmp prpa7
21049: 0:
21050: jsb syspp # get print parameters
21051: tstl r7 # jump if lines/page specified
21052: bnequ prpa1
21053: movl $cfp$m,r7 # else use a large value
21054: ashl $-1,r7,r7 # but not too large
21055: #
21056: # STORE LINE COUNT/PAGE
21057: #
21058: prpa1: movl r7,lstnp # store number of lines/page
21059: movl r7,lstlc # pretend page is full initially
21060: clrl lstpg # clear page number
21061: movl prlen,r7 # get prior length if any
21062: beqlu prpa2 # skip if no length
21063: cmpl r6,r7 # skip storing if too big
21064: bgtru prpa3
21065: #
21066: # STORE PRINT BUFFER LENGTH
21067: #
21068: prpa2: movl r6,prlen # store value
21069: #
21070: # PROCESS BITS OPTIONS
21071: #
21072: prpa3: movl bits3,r7 # bit 3 mask
21073: mcoml r8,r11 # get -nolist bit
21074: bicl2 r11,r7
21075: beqlu prpa4 # skip if clear
21076: clrl cswls # set -nolist
21077: #
21078: # CHECK IF FAIL REPORTS GOTO INTERACTIVE CHANNEL
21079: #
21080: prpa4: movl bits1,r7 # bit 1 mask
21081: mcoml r8,r11 # get bit
21082: bicl2 r11,r7
21083: movl r7,erich # store int. chan. error flag
21084: movl bits2,r7 # bit 2 mask
21085: mcoml r8,r11 # get bit
21086: bicl2 r11,r7
21087: movl r7,prich # flag for std printer on int. chan.
21088: movl bits4,r7 # bit 4 mask
21089: mcoml r8,r11 # get bit
21090: bicl2 r11,r7
21091: movl r7,cpsts # flag for compile stats suppressn.
21092: movl bits5,r7 # bit 5 mask
21093: mcoml r8,r11 # get bit
21094: bicl2 r11,r7
21095: movl r7,exsts # flag for exec stats suppression
21096: #page
21097: #
21098: # PRPAR (CONTINUED)
21099: #
21100: movl bits6,r7 # bit 6 mask
21101: mcoml r8,r11 # get bit
21102: bicl2 r11,r7
21103: movl r7,precl # extended/compact listing flag
21104: subl2 $num08,r6 # point 8 chars from line end
21105: tstl r7 # jump if not extended
21106: beqlu prpa5
21107: movl r6,lstpo # store for listing page headings
21108: #
21109: # CONTINUE OPTION PROCESSING
21110: #
21111: prpa5: movl bits7,r7 # bit 7 mask
21112: mcoml r8,r11 # get bit 7
21113: bicl2 r11,r7
21114: movl r7,cswex # set -noexecute if non-zero
21115: movl bit10,r7 # bit 10 mask
21116: mcoml r8,r11 # get bit 10
21117: bicl2 r11,r7
21118: movl r7,headp # pretend printed to omit headers
21119: movl bits9,r7 # bit 9 mask
21120: mcoml r8,r11 # get bit 9
21121: bicl2 r11,r7
21122: movl r7,prsto # keep it as std listing option
21123: tstl r7 # skip if clear
21124: beqlu prpa6
21125: movl prlen,r6 # get print buffer length
21126: subl2 $num08,r6 # point 8 chars from line end
21127: movl r6,lstpo # store page offset
21128: #
21129: # CHECK FOR TERMINAL
21130: #
21131: prpa6: mcoml bits8,r11 # see if terminal to be activated
21132: bicl2 r11,r8
21133: beqlu 0f # jump if terminal required
21134: jmp prpa7
21135: 0:
21136: tstl initr # jump if no terminal to detach
21137: beqlu prpa8
21138: movl $v$ter,r10 # ptr to /terminal/
21139: jsb gtnvr # get vrblk pointer
21140: .long invalid$ # cant fail
21141: movl $nulls,4*vrval(r9) # clear value of terminal
21142: jsb setvr # remove association
21143: jmp prpa8 # return
21144: #
21145: # ASSOCIATE TERMINAL
21146: #
21147: prpa7: movl sp,initr # note terminal associated
21148: tstl dnamb # cant if memory not organised
21149: beqlu prpa8
21150: movl $v$ter,r10 # point to terminal string
21151: movl $trtou,r7 # output trace type
21152: jsb inout # attach output trblk to vrblk
21153: movl r9,-(sp) # stack trblk ptr
21154: movl $v$ter,r10 # point to terminal string
21155: movl $trtin,r7 # input trace type
21156: jsb inout # attach input trace blk
21157: movl (sp)+,4*vrval(r9)# add output trblk to chain
21158: #
21159: # RETURN POINT
21160: #
21161: prpa8: rsb # return
21162: #enp # end procedure prpar
21163: #page
21164: #
21165: # PRTCH -- PRINT A CHARACTER
21166: #
21167: # PRTCH IS USED TO PRINT A SINGLE CHARACTER
21168: #
21169: # (WA) CHARACTER TO BE PRINTED
21170: # JSR PRTCH CALL TO PRINT CHARACTER
21171: #
21172: prtch: #prc # entry point
21173: movl r9,-(sp) # save xr
21174: cmpl profs,prlen # jump if room in buffer
21175: bnequ prch1
21176: jsb prtnl # else print this line
21177: #
21178: # HERE AFTER MAKING SURE WE HAVE ROOM
21179: #
21180: prch1: movl prbuf,r9 # point to print buffer
21181: movl profs,r11 # [get in scratch register]
21182: movab cfp$f(r9)[r11],r9# point to next character location
21183: movb r6,(r9) # store new character
21184: #csc r9 # complete store characters
21185: incl profs # bump pointer
21186: movl (sp)+,r9 # restore entry xr
21187: rsb # return to prtch caller
21188: #enp # end procedure prtch
21189: #page
21190: #
21191: # PRTIC -- PRINT TO INTERACTIVE CHANNEL
21192: #
21193: # PRTIC IS CALLED TO PRINT THE CONTENTS OF THE STANDARD
21194: # PRINT BUFFER TO THE INTERACTIVE CHANNEL. IT IS ONLY
21195: # CALLED AFTER PRTST HAS SET UP THE STRING FOR PRINTING.
21196: # IT DOES NOT CLEAR THE BUFFER.
21197: #
21198: # JSR PRTIC CALL FOR PRINT
21199: # (WA,WB) DESTROYED
21200: #
21201: prtic: #prc # entry point
21202: movl r9,-(sp) # save xr
21203: movl prbuf,r9 # point to buffer
21204: movl profs,r6 # no of chars
21205: jsb syspi # print
21206: .long prtc2 # fail return
21207: #
21208: # RETURN
21209: #
21210: prtc1: movl (sp)+,r9 # restore xr
21211: rsb # return
21212: #
21213: # ERROR OCCURED
21214: #
21215: prtc2: clrl erich # prevent looping
21216: jmp er_252 # error on printing to interactive channel
21217: jmp prtc1 # return
21218: #enp # procedure prtic
21219: #page
21220: #
21221: # PRTIS -- PRINT TO INTERACTIVE AND STANDARD PRINTER
21222: #
21223: # PRTIS PUTS A LINE FROM THE PRINT BUFFER ONTO THE
21224: # INTERACTIVE CHANNEL (IF ANY) AND THE STANDARD PRINTER.
21225: # IT ALWAYS PRINTS TO THE STANDARD PRINTER BUT DOES
21226: # NOT DUPLICATE LINES IF THE STANDARD PRINTER IS
21227: # INTERACTIVE. IT CLEARS DOWN THE PRINT BUFFER.
21228: #
21229: # JSR PRTIS CALL FOR PRINTING
21230: # (WA,WB) DESTROYED
21231: #
21232: prtis: #prc # entry point
21233: tstl prich # jump if standard printer is int.ch.
21234: bnequ prts1
21235: tstl erich # skip if not doing int. error reps.
21236: beqlu prts1
21237: jsb prtic # print to interactive channel
21238: #
21239: # MERGE AND EXIT
21240: #
21241: prts1: jsb prtnl # print to standard printer
21242: rsb # return
21243: #enp # end procedure prtis
21244: #page
21245: #
21246: # PRTIN -- PRINT AN INTEGER
21247: #
21248: # PRTIN PRINTS THE INTEGER VALUE WHICH IS IN THE INTEGER
21249: # ACCUMULATOR. BLOCKS BUILT IN DYNAMIC STORAGE
21250: # DURING THIS PROCESS ARE IMMEDIATELY DELETED.
21251: #
21252: # (IA) INTEGER VALUE TO BE PRINTED
21253: # JSR PRTIN CALL TO PRINT INTEGER
21254: # (IA,RA) DESTROYED
21255: #
21256: prtin: #prc # entry point
21257: movl r9,-(sp) # save xr
21258: jsb icbld # build integer block
21259: cmpl r9,dnamb # jump if icblk below dynamic
21260: blequ prti1
21261: cmpl r9,dnamp # jump if above dynamic
21262: bgequ prti1
21263: movl r9,dnamp # immediately delete it
21264: #
21265: # DELETE ICBLK FROM DYNAMIC STORE
21266: #
21267: prti1: movl r9,-(sp) # stack ptr for gtstg
21268: jsb gtstg # convert to string
21269: .long invalid$ # convert error is impossible
21270: movl r9,dnamp # reset pointer to delete scblk
21271: jsb prtst # print integer string
21272: movl (sp)+,r9 # restore entry xr
21273: rsb # return to prtin caller
21274: #enp # end procedure prtin
21275: #page
21276: #
21277: # PRTMI -- PRINT MESSAGE AND INTEGER
21278: #
21279: # PRTMI IS USED TO PRINT MESSAGES TOGETHER WITH AN INTEGER
21280: # VALUE STARTING IN COLUMN 15 (USED BY THE ROUTINES AT
21281: # THE END OF COMPILATION).
21282: #
21283: # JSR PRTMI CALL TO PRINT MESSAGE AND INTEGER
21284: #
21285: prtmi: #prc # entry point
21286: jsb prtst # print string message
21287: movl $prtmf,profs # set offset to col 15
21288: jsb prtin # print integer
21289: jsb prtnl # print line
21290: rsb # return to prtmi caller
21291: #enp # end procedure prtmi
21292: #page
21293: #
21294: # PRTMX -- AS PRTMI WITH EXTRA COPY TO INTERACTIVE CHAN.
21295: #
21296: # JSR PRTMX CALL FOR PRINTING
21297: # (WA,WB) DESTROYED
21298: #
21299: prtmx: #prc # entry point
21300: jsb prtst # print string message
21301: movl $prtmf,profs # set ptr to column 15
21302: jsb prtin # print integer
21303: jsb prtis # print line
21304: rsb # return
21305: #enp # end procedure prtmx
21306: #page
21307: #
21308: # PRTNL -- PRINT NEW LINE (END PRINT LINE)
21309: #
21310: # PRTNL PRINTS THE CONTENTS OF THE PRINT BUFFER, RESETS
21311: # THE BUFFER TO ALL BLANKS AND RESETS THE PRINT POINTER.
21312: #
21313: # JSR PRTNL CALL TO PRINT LINE
21314: #
21315: prtnl: #prc # entry point
21316: tstl headp # were headers printed
21317: bnequ prnl0
21318: jsb prtps # no - print them
21319: #
21320: # CALL SYSPR
21321: #
21322: prnl0: movl r9,-(sp) # save entry xr
21323: movl r6,prtsa # save wa
21324: movl r7,prtsb # save wb
21325: movl prbuf,r9 # load pointer to buffer
21326: movl profs,r6 # load number of chars in buffer
21327: jsb syspr # call system print routine
21328: .long prnl2 # jump if failed
21329: movl prlnw,r6 # load length of buffer in words
21330: addl2 $4*schar,r9 # point to chars of buffer
21331: movl nullw,r7 # get word of blanks
21332: #
21333: # LOOP TO BLANK BUFFER
21334: #
21335: prnl1: movl r7,(r9)+ # store word of blanks, bump ptr
21336: sobgtr r6,prnl1 # loop till all blanked
21337: #
21338: # EXIT POINT
21339: #
21340: movl prtsb,r7 # restore wb
21341: movl prtsa,r6 # restore wa
21342: movl (sp)+,r9 # restore entry xr
21343: clrl profs # reset print buffer pointer
21344: rsb # return to prtnl caller
21345: #
21346: # FILE FULL OR NO OUTPUT FILE FOR LOAD MODULE
21347: #
21348: prnl2: tstl prtef # jump if not first time
21349: bnequ prnl3
21350: movl sp,prtef # mark first occurrence
21351: jmp er_253 # print limit exceeded on standard output channel
21352: #
21353: # STOP AT ONCE
21354: #
21355: prnl3: movl $nini8,r7 # ending code
21356: movl kvstn,r6 # statement number
21357: jsb sysej # stop
21358: #enp # end procedure prtnl
21359: #page
21360: #
21361: # PRTNM -- PRINT VARIABLE NAME
21362: #
21363: # PRTNM IS USED TO PRINT A CHARACTER REPRESENTATION OF THE
21364: # NAME OF A VARIABLE (NOT A VALUE OF DATATYPE NAME)
21365: # NAMES OF PSEUDO-VARIABLES MAY NOT BE PASSED TO PRTNM.
21366: #
21367: # (XL) NAME BASE
21368: # (WA) NAME OFFSET
21369: # JSR PRTNM CALL TO PRINT NAME
21370: # (WB,WC,RA) DESTROYED
21371: #
21372: prtnm: #prc # entry point (recursive, see prtvl)
21373: movl r6,-(sp) # save wa (offset is collectable)
21374: movl r9,-(sp) # save entry xr
21375: movl r10,-(sp) # save name base
21376: cmpl r10,state # jump if not natural variable
21377: bgequ prn02
21378: #
21379: # HERE FOR NATURAL VARIABLE NAME, RECOGNIZED BY THE FACT
21380: # THAT THE NAME BASE POINTS INTO THE STATIC AREA.
21381: #
21382: movl r10,r9 # point to vrblk
21383: jsb prtvn # print name of variable
21384: #
21385: # COMMON EXIT POINT
21386: #
21387: prn01: movl (sp)+,r10 # restore name base
21388: movl (sp)+,r9 # restore entry value of xr
21389: movl (sp)+,r6 # restore wa
21390: rsb # return to prtnm caller
21391: #
21392: # HERE FOR CASE OF NON-NATURAL VARIABLE
21393: #
21394: prn02: movl r6,r7 # copy name offset
21395: cmpl (r10),$b$pdt # jump if array or table
21396: bnequ prn03
21397: #
21398: # FOR PROGRAM DEFINED DATATYPE, PRT FLD NAME, LEFT PAREN
21399: #
21400: movl 4*pddfp(r10),r9 # load pointer to dfblk
21401: addl2 r6,r9 # add name offset
21402: movl 4*pdfof(r9),r9 # load vrblk pointer for field
21403: jsb prtvn # print field name
21404: movl $ch$pp,r6 # load left paren
21405: jsb prtch # print character
21406: #page
21407: #
21408: # PRTNM (CONTINUED)
21409: #
21410: # NOW WE PRINT AN IDENTIFYING NAME FOR THE OBJECT IF ONE
21411: # CAN BE FOUND. THE FOLLOWING CODE SEARCHES FOR A NATURAL
21412: # VARIABLE WHICH CONTAINS THIS OBJECT AS VALUE. IF SUCH A
21413: # VARIABLE IS FOUND, ITS NAME IS PRINTED, ELSE THE VALUE
21414: # OF THE OBJECT (AS PRINTED BY PRTVL) IS USED INSTEAD.
21415: #
21416: # FIRST WE POINT TO THE PARENT TBBLK IF THIS IS THE CASE OF
21417: # A TABLE ELEMENT. TO DO THIS, CHASE DOWN THE TRNXT CHAIN.
21418: #
21419: prn03: cmpl (r10),$b$tet # jump if we got there (or not te)
21420: bnequ prn04
21421: movl 4*tenxt(r10),r10# else move out on chain
21422: jmp prn03 # and loop back
21423: #
21424: # NOW WE ARE READY FOR THE SEARCH. TO SPEED THINGS UP IN
21425: # THE CASE OF CALLS FROM DUMP WHERE THE SAME NAME BASE
21426: # WILL OCCUR REPEATEDLY WHILE DUMPING AN ARRAY OR TABLE,
21427: # WE REMEMBER THE LAST VRBLK POINTER FOUND IN PRNMV. SO
21428: # FIRST CHECK TO SEE IF WE HAVE THIS ONE AGAIN.
21429: #
21430: prn04: movl prnmv,r9 # point to vrblk we found last time
21431: movl hshtb,r6 # point to hash table in case not
21432: jmp prn07 # jump into search for special check
21433: #
21434: # LOOP THROUGH HASH SLOTS
21435: #
21436: prn05: movl r6,r9 # copy slot pointer
21437: addl2 $4,r6 # bump slot pointer
21438: subl2 $4*vrnxt,r9 # introduce standard vrblk offset
21439: #
21440: # LOOP THROUGH VRBLKS ON ONE HASH CHAIN
21441: #
21442: prn06: movl 4*vrnxt(r9),r9 # point to next vrblk on hash chain
21443: #
21444: # MERGE HERE FIRST TIME TO CHECK BLOCK WE FOUND LAST TIME
21445: #
21446: prn07: movl r9,r8 # copy vrblk pointer
21447: beqlu prn09 # jump if chain end (or prnmv zero)
21448: #page
21449: #
21450: # PRTNM (CONTINUED)
21451: #
21452: # LOOP TO FIND VALUE (CHASE DOWN POSSIBLE TRBLK CHAIN)
21453: #
21454: prn08: movl 4*vrval(r9),r9 # load value
21455: cmpl (r9),$b$trt # loop if that was a trblk
21456: beqlu prn08
21457: #
21458: # NOW WE HAVE THE VALUE, IS THIS THE BLOCK WE WANT
21459: #
21460: cmpl r9,r10 # jump if this matches the name base
21461: beqlu prn10
21462: movl r8,r9 # else point back to that vrblk
21463: jmp prn06 # and loop back
21464: #
21465: # HERE TO MOVE TO NEXT HASH SLOT
21466: #
21467: prn09: cmpl r6,hshte # loop back if more to go
21468: blssu prn05
21469: movl r10,r9 # else not found, copy value pointer
21470: jsb prtvl # print value
21471: jmp prn11 # and merge ahead
21472: #
21473: # HERE WHEN WE FIND A MATCHING ENTRY
21474: #
21475: prn10: movl r8,r9 # copy vrblk pointer
21476: movl r9,prnmv # save for next time in
21477: jsb prtvn # print variable name
21478: #
21479: # MERGE HERE IF NO ENTRY FOUND
21480: #
21481: prn11: movl (r10),r8 # load first word of name base
21482: cmpl r8,$b$pdt # jump if not program defined
21483: bnequ prn13
21484: #
21485: # FOR PROGRAM DEFINED DATATYPE, ADD RIGHT PAREN AND EXIT
21486: #
21487: movl $ch$rp,r6 # load right paren, merge
21488: #
21489: # MERGE HERE TO PRINT FINAL RIGHT PAREN OR BRACKET
21490: #
21491: prn12: jsb prtch # print final character
21492: movl r7,r6 # restore name offset
21493: jmp prn01 # merge back to exit
21494: #page
21495: #
21496: # PRTNM (CONTINUED)
21497: #
21498: # HERE FOR ARRAY OR TABLE
21499: #
21500: prn13: movl $ch$bb,r6 # load left bracket
21501: jsb prtch # and print it
21502: movl (sp),r10 # restore block pointer
21503: movl (r10),r8 # load type word again
21504: cmpl r8,$b$tet # jump if not table
21505: bnequ prn15
21506: #
21507: # HERE FOR TABLE, PRINT SUBSCRIPT VALUE
21508: #
21509: movl 4*tesub(r10),r9 # load subscript value
21510: movl r7,r10 # save name offset
21511: jsb prtvl # print subscript value
21512: movl r10,r7 # restore name offset
21513: #
21514: # MERGE HERE FROM ARRAY CASE TO PRINT RIGHT BRACKET
21515: #
21516: prn14: movl $ch$rb,r6 # load right bracket
21517: jmp prn12 # merge back to print it
21518: #
21519: # HERE FOR ARRAY OR VECTOR, TO PRINT SUBSCRIPT(S)
21520: #
21521: prn15: movl r7,r6 # copy name offset
21522: ashl $-2,r6,r6 # convert to words
21523: cmpl r8,$b$art # jump if arblk
21524: beqlu prn16
21525: #
21526: # HERE FOR VECTOR
21527: #
21528: subl2 $vcvlb,r6 # adjust for standard fields
21529: movl r6,r5 # move to integer accum
21530: jsb prtin # print linear subscript
21531: jmp prn14 # merge back for right bracket
21532: #page
21533: #
21534: # PRTNM (CONTINUED)
21535: #
21536: # HERE FOR ARRAY. FIRST CALCULATE ABSOLUTE SUBSCRIPT
21537: # OFFSETS BY SUCCESSIVE DIVISIONS BY THE DIMENSION VALUES.
21538: # THIS MUST BE DONE RIGHT TO LEFT SINCE THE ELEMENTS ARE
21539: # STORED ROW-WISE. THE SUBSCRIPTS ARE STACKED AS INTEGERS.
21540: #
21541: prn16: movl 4*arofs(r10),r8 # load length of bounds info
21542: addl2 $4,r8 # adjust for arpro field
21543: ashl $-2,r8,r8 # convert to words
21544: subl2 r8,r6 # get linear zero-origin subscript
21545: movl r6,r5 # get integer value
21546: movl 4*arndm(r10),r6 # set num of dimensions as loop count
21547: addl2 4*arofs(r10),r10# point past bounds information
21548: subl2 $4*arlbd,r10 # set ok offset for proper ptr later
21549: #
21550: # LOOP TO STACK SUBSCRIPT OFFSETS
21551: #
21552: prn17: subl2 $4*ardms,r10 # point to next set of bounds
21553: movl r5,prnsi # save current offset
21554: ashq $-32,r4,r4 # get remainder on dividing by dimens
21555: ediv 4*ardim(r10),r4,r11,r5
21556: movl r5,-(sp) # store on stack (one word)
21557: movl prnsi,r5 # reload argument
21558: divl2 4*ardim(r10),r5 # divide to get quotient
21559: sobgtr r6,prn17 # loop till all stacked
21560: clrl r9 # set offset to first set of bounds
21561: movl 4*arndm(r10),r7 # load count of dims to control loop
21562: jmp prn19 # jump into print loop
21563: #
21564: # LOOP TO PRINT SUBSCRIPTS FROM STACK ADJUSTING BY ADDING
21565: # THE APPROPRIATE LOW BOUND VALUE FROM THE ARBLK
21566: #
21567: prn18: movl $ch$cm,r6 # load a comma
21568: jsb prtch # print it
21569: #
21570: # MERGE HERE FIRST TIME IN (NO COMMA REQUIRED)
21571: #
21572: prn19: movl (sp)+,r5 # load subscript offset as integer
21573: addl2 r9,r10 # point to current lbd
21574: addl2 4*arlbd(r10),r5 # add lbd to get signed subscript
21575: subl2 r9,r10 # point back to start of arblk
21576: jsb prtin # print subscript
21577: addl2 $4*ardms,r9 # bump offset to next bounds
21578: sobgtr r7,prn18 # loop back till all printed
21579: jmp prn14 # merge back to print right bracket
21580: #enp # end procedure prtnm
21581: #page
21582: #
21583: # PRTNV -- PRINT NAME VALUE
21584: #
21585: # PRTNV IS USED BY THE TRACE AND DUMP ROUTINES TO PRINT
21586: # A LINE OF THE FORM
21587: #
21588: # NAME = VALUE
21589: #
21590: # NOTE THAT THE NAME INVOLVED CAN NEVER BE A PSEUDO-VAR
21591: #
21592: # (XL) NAME BASE
21593: # (WA) NAME OFFSET
21594: # JSR PRTNV CALL TO PRINT NAME = VALUE
21595: # (WB,WC,RA) DESTROYED
21596: #
21597: prtnv: #prc # entry point
21598: jsb prtnm # print argument name
21599: movl r9,-(sp) # save entry xr
21600: movl r6,-(sp) # save name offset (collectable)
21601: movl $tmbeb,r9 # point to blank equal blank
21602: jsb prtst # print it
21603: movl r10,r9 # copy name base
21604: addl2 r6,r9 # point to value
21605: movl (r9),r9 # load value pointer
21606: jsb prtvl # print value
21607: jsb prtnl # terminate line
21608: movl (sp)+,r6 # restore name offset
21609: movl (sp)+,r9 # restore entry xr
21610: rsb # return to caller
21611: #enp # end procedure prtnv
21612: #page
21613: #
21614: # PRTPG -- PRINT A PAGE THROW
21615: #
21616: # PRINTS A PAGE THROW OR A FEW BLANK LINES ON THE STANDARD
21617: # LISTING CHANNEL DEPENDING ON THE LISTING OPTIONS CHOSEN.
21618: #
21619: # JSR PRTPG CALL FOR PAGE EJECT
21620: #
21621: prtpg: #prc # entry point
21622: cmpl stage,$stgxt # jump if execution time
21623: beqlu prp01
21624: tstl lstlc # return if top of page already
21625: bnequ 0f
21626: jmp prp06
21627: 0:
21628: clrl lstlc # clear line count
21629: #
21630: # CHECK TYPE OF LISTING
21631: #
21632: prp01: movl r9,-(sp) # preserve xr
21633: tstl prstd # eject if flag set
21634: bnequ prp02
21635: tstl prich # jump if interactive listing channel
21636: bnequ prp03
21637: tstl precl # jump if compact listing
21638: beqlu prp03
21639: #
21640: # PERFORM AN EJECT
21641: #
21642: prp02: jsb sysep # eject
21643: jmp prp04 # merge
21644: #
21645: # COMPACT OR INTERACTIVE CHANNEL LISTING. CANT PRINT
21646: # BLANKS UNTIL CHECK MADE FOR HEADERS PRINTED AND FLAG SET.
21647: #
21648: #
21649: prp03: movl headp,r9 # remember headp
21650: movl sp,headp # set to avoid repeated prtpg calls
21651: jsb prtnl # print blank line
21652: jsb prtnl # print blank line
21653: jsb prtnl # print blank line
21654: movl $num03,lstlc # count blank lines
21655: movl r9,headp # restore header flag
21656: #page
21657: #
21658: # PRPTG (CONTINUED)
21659: #
21660: # PRINT THE HEADING
21661: #
21662: prp04: tstl headp # jump if header listed
21663: bnequ prp05
21664: movl sp,headp # mark headers printed
21665: movl r10,-(sp) # keep xl
21666: movl $headr,r9 # point to listing header
21667: jsb prtst # place it
21668: jsb sysid # get system identification
21669: jsb prtst # append extra chars
21670: jsb prtnl # print it
21671: movl r10,r9 # extra header line
21672: jsb prtst # place it
21673: jsb prtnl # print it
21674: jsb prtnl # print a blank
21675: jsb prtnl # and another
21676: addl2 $num04,lstlc # four header lines printed
21677: movl (sp)+,r10 # restore xl
21678: #
21679: # MERGE IF HEADER NOT PRINTED
21680: #
21681: prp05: movl (sp)+,r9 # restore xr
21682: #
21683: # RETURN
21684: #
21685: prp06: rsb # return
21686: #enp # end procedure prtpg
21687: #page
21688: #
21689: # PRTPS - PRINT PAGE WITH TEST FOR STANDARD LISTING OPTION
21690: #
21691: # IF THE STANDARD LISTING OPTION IS SELECTED, INSIST THAT
21692: # AN EJECT BE DONE
21693: #
21694: # JSR PRTPS CALL FOR EJECT
21695: #
21696: prtps: #prc # entry point
21697: movl prsto,prstd # copy option flag
21698: jsb prtpg # print page
21699: clrl prstd # clear flag
21700: rsb # return
21701: #enp # end procedure prtps
21702: #page
21703: #
21704: # PRTSN -- PRINT STATEMENT NUMBER
21705: #
21706: # PRTSN IS USED TO INITIATE A PRINT TRACE LINE BY PRINTING
21707: # ASTERISKS AND THE CURRENT STATEMENT NUMBER. THE ACTUAL
21708: # FORMAT OF THE OUTPUT GENERATED IS.
21709: #
21710: # ***NNNNN**** III.....IIII
21711: #
21712: # NNNNN IS THE STATEMENT NUMBER WITH LEADING ZEROS REPLACED
21713: # BY ASTERISKS (E.G. *******9****)
21714: #
21715: # III...III REPRESENTS A VARIABLE LENGTH OUTPUT CONSISTING
21716: # OF A NUMBER OF LETTER I CHARACTERS EQUAL TO FNCLEVEL.
21717: #
21718: # JSR PRTSN CALL TO PRINT STATEMENT NUMBER
21719: # (WC) DESTROYED
21720: #
21721: prtsn: #prc # entry point
21722: movl r9,-(sp) # save entry xr
21723: movl r6,prsna # save entry wa
21724: movl $tmasb,r9 # point to asterisks
21725: jsb prtst # print asterisks
21726: movl $num04,profs # point into middle of asterisks
21727: movl kvstn,r5 # load statement number as integer
21728: jsb prtin # print integer statement number
21729: movl $prsnf,profs # point past asterisks plus blank
21730: movl kvfnc,r9 # get fnclevel
21731: movl $ch$li,r6 # set letter i
21732: #
21733: # LOOP TO GENERATE LETTER I FNCLEVEL TIMES
21734: #
21735: prsn1: tstl r9 # jump if all set
21736: beqlu prsn2
21737: jsb prtch # else print an i
21738: decl r9 # decrement counter
21739: jmp prsn1 # loop back
21740: #
21741: # MERRE WITH ALL LETTER I CHARACTERS GENERATED
21742: #
21743: prsn2: movl $ch$bl,r6 # get blank
21744: jsb prtch # print blank
21745: movl prsna,r6 # restore entry wa
21746: movl (sp)+,r9 # restore entry xr
21747: rsb # return to prtsn caller
21748: #enp # end procedure prtsn
21749: #page
21750: #
21751: # PRTST -- PRINT STRING
21752: #
21753: # PRTST PLACES A STRING OF CHARACTERS IN THE PRINT BUFFER
21754: #
21755: # SEE PRTNL FOR GLOBAL LOCATIONS USED
21756: #
21757: # NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL)
21758: # IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN)
21759: #
21760: # (XR) STRING TO BE PRINTED
21761: # JSR PRTST CALL TO PRINT STRING
21762: # (PROFS) UPDATED PAST CHARS PLACED
21763: #
21764: prtst: #prc # entry point
21765: tstl headp # were headers printed
21766: bnequ prst0
21767: jsb prtps # no - print them
21768: #
21769: # CALL SYSPR
21770: #
21771: prst0: movl r6,prsva # save wa
21772: movl r7,prsvb # save wb
21773: clrl r7 # set chars printed count to zero
21774: #
21775: # LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING
21776: #
21777: prst1: movl 4*sclen(r9),r6 # load string length
21778: subl2 r7,r6 # subtract count of chars already out
21779: bnequ 0f # jump to exit if none left
21780: jmp prst4
21781: 0:
21782: movl r10,-(sp) # else stack entry xl
21783: movl r9,-(sp) # save argument
21784: movl r9,r10 # copy for eventual move
21785: movl prlen,r9 # load print buffer length
21786: subl2 profs,r9 # get chars left in print buffer
21787: bnequ prst2 # skip if room left on this line
21788: jsb prtnl # else print this line
21789: movl prlen,r9 # and set full width available
21790: #page
21791: #
21792: # PRTST (CONTINUED)
21793: #
21794: # HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER
21795: #
21796: prst2: cmpl r6,r9 # jump if room for rest of string
21797: blequ prst3
21798: movl r9,r6 # else set to fill line
21799: #
21800: # MERGE HERE WITH CHARACTER COUNT IN WA
21801: #
21802: prst3: movl prbuf,r9 # point to print buffer
21803: movab cfp$f(r10)[r7],r10 # point to location in string
21804: movl profs,r11 # [get in scratch register]
21805: movab cfp$f(r9)[r11],r9# point to location in buffer
21806: addl2 r6,r7 # bump string chars count
21807: addl2 r6,profs # bump buffer pointer
21808: movl r7,prsvc # preserve char counter
21809: jsb sbmvc # move characters to buffer
21810: movl prsvc,r7 # recover char counter
21811: movl (sp)+,r9 # restore argument pointer
21812: movl (sp)+,r10 # restore entry xl
21813: jmp prst1 # loop back to test for more
21814: #
21815: # HERE TO EXIT AFTER PRINTING STRING
21816: #
21817: prst4: movl prsvb,r7 # restore entry wb
21818: movl prsva,r6 # restore entry wa
21819: rsb # return to prtst caller
21820: #enp # end procedure prtst
21821: #page
21822: #
21823: # PRTTR -- PRINT TO TERMINAL
21824: #
21825: # CALLED TO PRINT CONTENTS OF STANDARD PRINT BUFFER TO
21826: # ONLINE TERMINAL. CLEARS BUFFER DOWN AND RESETS PROFS.
21827: #
21828: # JSR PRTTR CALL FOR PRINT
21829: # (WA,WB) DESTROYED
21830: #
21831: prttr: #prc # entry point
21832: movl r9,-(sp) # save xr
21833: jsb prtic # print buffer contents
21834: movl prbuf,r9 # point to print bfr to clear it
21835: movl prlnw,r6 # get buffer length
21836: addl2 $4*schar,r9 # point past scblk header
21837: movl nullw,r7 # get blanks
21838: #
21839: # LOOP TO CLEAR BUFFER
21840: #
21841: prtt1: movl r7,(r9)+ # clear a word
21842: sobgtr r6,prtt1 # loop
21843: clrl profs # reset profs
21844: movl (sp)+,r9 # restore xr
21845: rsb # return
21846: #enp # end procedure prttr
21847: #page
21848: #
21849: # PRTVL -- PRINT A VALUE
21850: #
21851: # PRTVL PLACES AN APPROPRIATE CHARACTER REPRESENTATION OF
21852: # A DATA VALUE IN THE PRINT BUFFER FOR DUMP/TRACE USE.
21853: #
21854: # (XR) VALUE TO BE PRINTED
21855: # JSR PRTVL CALL TO PRINT VALUE
21856: # (WA,WB,WC,RA) DESTROYED
21857: #
21858: prtvl: #prc # entry point, recursive
21859: movl r10,-(sp) # save entry xl
21860: movl r9,-(sp) # save argument
21861: jsb sbchk # check for stack overflow
21862: #
21863: # LOOP BACK HERE AFTER FINDING A TRAP BLOCK (TRBLK)
21864: #
21865: prv01: movl 4*idval(r9),prvsi# copy idval (if any)
21866: movl (r9),r10 # load first word of block
21867: movzwl -2(r10),r10 # load entry point id
21868: casel r10,$0,$bl$$t # switch on block type
21869: 5:
21870: .word prv05-5b # arblk
21871: .word prv15-5b # bcblk
21872: .word prv02-5b
21873: .word prv02-5b
21874: .word prv08-5b # icblk
21875: .word prv09-5b # nmblk
21876: .word prv02-5b
21877: .word prv02-5b
21878: .word prv02-5b
21879: .word prv08-5b # rcblk
21880: .word prv11-5b # scblk
21881: .word prv12-5b # seblk
21882: .word prv13-5b # tbblk
21883: .word prv13-5b # vcblk
21884: .word prv02-5b
21885: .word prv02-5b
21886: .word prv10-5b # pdblk
21887: .word prv04-5b # trblk
21888: #esw # end of switch on block type
21889: #
21890: # HERE FOR BLOCKS FOR WHICH WE JUST PRINT DATATYPE NAME
21891: #
21892: prv02: jsb dtype # get datatype name
21893: jsb prtst # print datatype name
21894: #
21895: # COMMON EXIT POINT
21896: #
21897: prv03: movl (sp)+,r9 # reload argument
21898: movl (sp)+,r10 # restore xl
21899: rsb # return to prtvl caller
21900: #
21901: # HERE FOR TRBLK
21902: #
21903: prv04: movl 4*trval(r9),r9 # load real value
21904: jmp prv01 # and loop back
21905: #page
21906: #
21907: # PRTVL (CONTINUED)
21908: #
21909: # HERE FOR ARRAY (ARBLK)
21910: #
21911: # PRINT ARRAY ( PROTOTYPE ) BLANK NUMBER IDVAL
21912: #
21913: prv05: movl r9,r10 # preserve argument
21914: movl $scarr,r9 # point to datatype name (array)
21915: jsb prtst # print it
21916: movl $ch$pp,r6 # load left paren
21917: jsb prtch # print left paren
21918: addl2 4*arofs(r10),r10# point to prototype
21919: movl (r10),r9 # load prototype
21920: jsb prtst # print prototype
21921: #
21922: # VCBLK, TBBLK, BCBLK MERGE HERE FOR ) BLANK NUMBER IDVAL
21923: #
21924: prv06: movl $ch$rp,r6 # load right paren
21925: jsb prtch # print right paren
21926: #
21927: # PDBLK MERGES HERE TO PRINT BLANK NUMBER IDVAL
21928: #
21929: prv07: movl $ch$bl,r6 # load blank
21930: jsb prtch # print it
21931: movl $ch$nm,r6 # load number sign
21932: jsb prtch # print it
21933: movl prvsi,r5 # get idval
21934: jsb prtin # print id number
21935: jmp prv03 # back to exit
21936: #
21937: # HERE FOR INTEGER (ICBLK), REAL (RCBLK)
21938: #
21939: # PRINT CHARACTER REPRESENTATION OF VALUE
21940: #
21941: prv08: movl r9,-(sp) # stack argument for gtstg
21942: jsb gtstg # convert to string
21943: .long invalid$ # error return is impossible
21944: jsb prtst # print the string
21945: movl r9,dnamp # delete garbage string from storage
21946: jmp prv03 # back to exit
21947: #page
21948: #
21949: # PRTVL (CONTINUED)
21950: #
21951: # NAME (NMBLK)
21952: #
21953: # FOR PSEUDO-VARIABLE, JUST PRINT DATATYPE NAME (NAME)
21954: # FOR ALL OTHER NAMES, PRINT DOT FOLLOWED BY NAME REP
21955: #
21956: prv09: movl 4*nmbas(r9),r10 # load name base
21957: movl (r10),r6 # load first word of block
21958: cmpl r6,$b$kvt # just print name if keyword
21959: bnequ 0f
21960: jmp prv02
21961: 0:
21962: cmpl r6,$b$evt # just print name if expression var
21963: bnequ 0f
21964: jmp prv02
21965: 0:
21966: movl $ch$dt,r6 # else get dot
21967: jsb prtch # and print it
21968: movl 4*nmofs(r9),r6 # load name offset
21969: jsb prtnm # print name
21970: jmp prv03 # back to exit
21971: #
21972: # PROGRAM DATATYPE (PDBLK)
21973: #
21974: # PRINT DATATYPE NAME CH$BL CH$NM IDVAL
21975: #
21976: prv10: jsb dtype # get datatype name
21977: jsb prtst # print datatype name
21978: jmp prv07 # merge back to print id
21979: #
21980: # HERE FOR STRING (SCBLK)
21981: #
21982: # PRINT QUOTE STRING-CHARACTERS QUOTE
21983: #
21984: prv11: movl $ch$sq,r6 # load single quote
21985: jsb prtch # print quote
21986: jsb prtst # print string value
21987: jsb prtch # print another quote
21988: jmp prv03 # back to exit
21989: #page
21990: #
21991: # PRTVL (CONTINUED)
21992: #
21993: # HERE FOR SIMPLE EXPRESSION (SEBLK)
21994: #
21995: # PRINT ASTERISK VARIABLE-NAME
21996: #
21997: prv12: movl $ch$as,r6 # load asterisk
21998: jsb prtch # print asterisk
21999: movl 4*sevar(r9),r9 # load variable pointer
22000: jsb prtvn # print variable name
22001: jmp prv03 # jump back to exit
22002: #
22003: # HERE FOR TABLE (TBBLK) AND ARRAY (VCBLK)
22004: #
22005: # PRINT DATATYPE ( PROTOTYPE ) BLANK NUMBER IDVAL
22006: #
22007: prv13: movl r9,r10 # preserve argument
22008: jsb dtype # get datatype name
22009: jsb prtst # print datatype name
22010: movl $ch$pp,r6 # load left paren
22011: jsb prtch # print left paren
22012: movl 4*tblen(r10),r6 # load length of block (=vclen)
22013: ashl $-2,r6,r6 # convert to word count
22014: subl2 $tbsi$,r6 # allow for standard fields
22015: cmpl (r10),$b$tbt # jump if table
22016: beqlu prv14
22017: addl2 $vctbd,r6 # for vcblk, adjust size
22018: #
22019: # PRINT PROTOTYPE
22020: #
22021: prv14: movl r6,r5 # move as integer
22022: jsb prtin # print integer prototype
22023: jmp prv06 # merge back for rest
22024: #page
22025: #
22026: # PRTVL (CONTINUED)
22027: #
22028: # HERE FOR BUFFER (BCBLK)
22029: #
22030: prv15: movl r9,r10 # preserve argument
22031: movl $scbuf,r9 # point to datatype name (buffer)
22032: jsb prtst # print it
22033: movl $ch$pp,r6 # load left paren
22034: jsb prtch # print left paren
22035: movl 4*bcbuf(r10),r9 # point to bfblk
22036: movl 4*bfalc(r9),r5 # load allocation size
22037: jsb prtin # print it
22038: movl $ch$cm,r6 # load comma
22039: jsb prtch # print it
22040: movl 4*bclen(r10),r5 # load defined length
22041: jsb prtin # print it
22042: jmp prv06 # merge to finish up
22043: #enp # end procedure prtvl
22044: #page
22045: #
22046: # PRTVN -- PRINT NATURAL VARIABLE NAME
22047: #
22048: # PRTVN PRINTS THE NAME OF A NATURAL VARIABLE
22049: #
22050: # (XR) POINTER TO VRBLK
22051: # JSR PRTVN CALL TO PRINT VARIABLE NAME
22052: #
22053: prtvn: #prc # entry point
22054: movl r9,-(sp) # stack vrblk pointer
22055: addl2 $4*vrsof,r9 # point to possible string name
22056: tstl 4*sclen(r9) # jump if not system variable
22057: bnequ prvn1
22058: movl 4*vrsvo(r9),r9 # point to svblk with name
22059: #
22060: # MERGE HERE WITH DUMMY SCBLK POINTER IN XR
22061: #
22062: prvn1: jsb prtst # print string name of variable
22063: movl (sp)+,r9 # restore vrblk pointer
22064: rsb # return to prtvn caller
22065: #enp # end procedure prtvn
22066: #page
22067: #
22068: # RCBLD -- BUILD A REAL BLOCK
22069: #
22070: # (RA) REAL VALUE FOR RCBLK
22071: # JSR RCBLD CALL TO BUILD REAL BLOCK
22072: # (XR) POINTER TO RESULT RCBLK
22073: # (WA) DESTROYED
22074: #
22075: rcbld: #prc # entry point
22076: movl dnamp,r9 # load pointer to next available loc
22077: addl2 $4*rcsi$,r9 # point past new rcblk
22078: cmpl r9,dname # jump if there is room
22079: blequ rcbl1
22080: movl $4*rcsi$,r6 # else load rcblk length
22081: jsb alloc # use standard allocator to get block
22082: addl2 r6,r9 # point past block to merge
22083: #
22084: # MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
22085: #
22086: rcbl1: movl r9,dnamp # set new pointer
22087: subl2 $4*rcsi$,r9 # point back to start of block
22088: movl $b$rcl,(r9) # store type word
22089: movf r2,4*rcval(r9) # store real value in rcblk
22090: rsb # return to rcbld caller
22091: #enp # end procedure rcbld
22092: #page
22093: #
22094: # READR -- READ NEXT SOURCE IMAGE AT COMPILE TIME
22095: #
22096: # READR IS USED TO READ THE NEXT SOURCE IMAGE. TO PROCESS
22097: # CONTINUATION CARDS PROPERLY, THE COMPILER MUST READ ONE
22098: # LINE AHEAD. THUS READR DOES NOT DESTROY THE CURRENT IMAGE
22099: # SEE ALSO THE NEXTS ROUTINE WHICH ACTUALLY GETS THE IMAGE.
22100: #
22101: # JSR READR CALL TO READ NEXT IMAGE
22102: # (XR) PTR TO NEXT IMAGE (0 IF NONE)
22103: # (R$CNI) COPY OF POINTER
22104: # (WA,WB,WC,XL) DESTROYED
22105: #
22106: readr: #prc # entry point
22107: movl r$cni,r9 # get ptr to next image
22108: bnequ read3 # exit if already read
22109: cmpl stage,$stgic # exit if not initial compile
22110: bnequ read3
22111: movl cswin,r6 # max read length
22112: jsb alocs # allocate buffer
22113: jsb sysrd # read input image
22114: .long read4 # jump if end of file
22115: movl sp,r7 # set trimr to perform trim
22116: cmpl 4*sclen(r9),cswin# use smaller of string lnth ..
22117: blequ read1
22118: movl cswin,4*sclen(r9)# ... and xxx of -inxxx
22119: #
22120: # PERFORM THE TRIM
22121: #
22122: read1: jsb trimr # trim trailing blanks
22123: #
22124: # MERGE HERE AFTER READ
22125: #
22126: read2: movl r9,r$cni # store copy of pointer
22127: #
22128: # MERGE HERE IF NO READ ATTEMPTED
22129: #
22130: read3: rsb # return to readr caller
22131: #
22132: # HERE ON END OF FILE
22133: #
22134: read4: movl r9,dnamp # pop unused scblk
22135: clrl r9 # zero ptr as result
22136: jmp read2 # merge
22137: #enp # end procedure readr
22138: #page
22139: #
22140: # SBSTR -- BUILD A SUBSTRING
22141: #
22142: # (XL) PTR TO SCBLK/BFBLK WITH CHARS
22143: # (WA) NUMBER OF CHARS IN SUBSTRING
22144: # (WB) OFFSET TO FIRST CHAR IN SCBLK
22145: # JSR SBSTR CALL TO BUILD SUBSTRING
22146: # (XR) PTR TO NEW SCBLK WITH SUBSTRING
22147: # (XL) ZERO
22148: # (WA,WB,WC,XL,IA) DESTROYED
22149: #
22150: # NOTE THAT SBSTR IS CALLED WITH A DUMMY STRING POINTER
22151: # (POINTING INTO A VRBLK OR SVBLK) TO COPY THE NAME OF A
22152: # VARIABLE AS A STANDARD STRING VALUE.
22153: #
22154: sbstr: #prc # entry point
22155: tstl r6 # jump if null substring
22156: beqlu sbst2
22157: jsb alocs # else allocate scblk
22158: movl r8,r6 # move number of characters
22159: movl r9,r8 # save ptr to new scblk
22160: movab cfp$f(r10)[r7],r10 # prepare to load chars from old blk
22161: movab cfp$f(r9),r9 # prepare to store chars in new blk
22162: jsb sbmvc # move characters to new string
22163: movl r8,r9 # then restore scblk pointer
22164: #
22165: # RETURN POINT
22166: #
22167: sbst1: clrl r10 # clear garbage pointer in xl
22168: rsb # return to sbstr caller
22169: #
22170: # HERE FOR NULL SUBSTRING
22171: #
22172: sbst2: movl $nulls,r9 # set null string as result
22173: jmp sbst1 # return
22174: #enp # end procedure sbstr
22175: #page
22176: #
22177: # SCANE -- SCAN AN ELEMENT
22178: #
22179: # SCANE IS CALLED AT COMPILE TIME (BY EXPAN ,CMPIL,CNCRD)
22180: # TO SCAN ONE ELEMENT FROM THE INPUT IMAGE.
22181: #
22182: # (SCNCC) NON-ZERO IF CALLED FROM CNCRD
22183: # JSR SCANE CALL TO SCAN ELEMENT
22184: # (XR) RESULT POINTER (SEE BELOW)
22185: # (XL) SYNTAX TYPE CODE (T$XXX)
22186: #
22187: # THE FOLLOWING GLOBAL LOCATIONS ARE USED.
22188: #
22189: # R$CIM POINTER TO STRING BLOCK (SCBLK)
22190: # FOR CURRENT INPUT IMAGE.
22191: #
22192: # R$CNI POINTER TO NEXT INPUT IMAGE STRING
22193: # POINTER (ZERO IF NONE).
22194: #
22195: # R$SCP SAVE POINTER (EXIT XR) FROM LAST
22196: # CALL IN CASE RESCAN IS SET.
22197: #
22198: # SCNBL THIS LOCATION IS SET NON-ZERO ON
22199: # EXIT IF SCANE SCANNED PAST BLANKS
22200: # BEFORE LOCATING THE CURRENT ELEMENT
22201: # THE END OF A LINE COUNTS AS BLANKS.
22202: #
22203: # SCNCC CNCRD SETS THIS NON-ZERO TO SCAN
22204: # CONTROL CARD NAMES AND CLEARS IT
22205: # ON RETURN
22206: #
22207: # SCNIL LENGTH OF CURRENT INPUT IMAGE
22208: #
22209: # SCNGO IF SET NON-ZERO ON ENTRY, F AND S
22210: # ARE RETURNED AS SEPARATE SYNTAX
22211: # TYPES (NOT LETTERS) (GOTO PRO-
22212: # CESSING). SCNGO IS RESET ON EXIT.
22213: #
22214: # SCNPT OFFSET TO CURRENT LOC IN R$CIM
22215: #
22216: # SCNRS IF SET NON-ZERO ON ENTRY, SCANE
22217: # RETURNS THE SAME RESULT AS ON THE
22218: # LAST CALL (RESCAN). SCNRS IS RESET
22219: # ON EXIT FROM ANY CALL TO SCANE.
22220: #
22221: # SCNTP SAVE SYNTAX TYPE FROM LAST
22222: # CALL (IN CASE RESCAN IS SET).
22223: #page
22224: #
22225: # SCANE (CONTINUED)
22226: #
22227: #
22228: #
22229: # ELEMENT SCANNED XL XR
22230: # --------------- -- --
22231: #
22232: # CONTROL CARD NAME 0 POINTER TO SCBLK FOR NAME
22233: #
22234: # UNARY OPERATOR T$UOP PTR TO OPERATOR DVBLK
22235: #
22236: # LEFT PAREN T$LPR T$LPR
22237: #
22238: # LEFT BRACKET T$LBR T$LBR
22239: #
22240: # COMMA T$CMA T$CMA
22241: #
22242: # FUNCTION CALL T$FNC PTR TO FUNCTION VRBLK
22243: #
22244: # VARIABLE T$VAR PTR TO VRBLK
22245: #
22246: # STRING CONSTANT T$CON PTR TO SCBLK
22247: #
22248: # INTEGER CONSTANT T$CON PTR TO ICBLK
22249: #
22250: # REAL CONSTANT T$CON PTR TO RCBLK
22251: #
22252: # BINARY OPERATOR T$BOP PTR TO OPERATOR DVBLK
22253: #
22254: # RIGHT PAREN T$RPR T$RPR
22255: #
22256: # RIGHT BRACKET T$RBR T$RBR
22257: #
22258: # COLON T$COL T$COL
22259: #
22260: # SEMI-COLON T$SMC T$SMC
22261: #
22262: # F (SCNGO NE 0) T$FGO T$FGO
22263: #
22264: # S (SCNGO NE 0) T$SGO T$SGO
22265: #page
22266: #
22267: # SCANE (CONTINUED)
22268: #
22269: # ENTRY POINT
22270: #
22271: scane: #prc # entry point
22272: clrl scnbl # reset blanks flag
22273: movl r6,scnsa # save wa
22274: movl r7,scnsb # save wb
22275: movl r8,scnsc # save wc
22276: tstl scnrs # jump if no rescan
22277: beqlu scn03
22278: #
22279: # HERE FOR RESCAN REQUEST
22280: #
22281: movl scntp,r10 # set previous returned scan type
22282: movl r$scp,r9 # set previous returned pointer
22283: clrl scnrs # reset rescan switch
22284: jmp scn13 # jump to exit
22285: #
22286: # COME HERE TO READ NEW IMAGE TO TEST FOR CONTINUATION
22287: #
22288: scn01: jsb readr # read next image
22289: movl $4*dvubs,r7 # set wb for not reading name
22290: tstl r9 # treat as semi-colon if none
22291: bnequ 0f
22292: jmp scn30
22293: 0:
22294: movab cfp$f(r9),r9 # else point to first character
22295: movzbl (r9),r8 # load first character
22296: cmpl r8,$ch$dt # jump if dot for continuation
22297: beqlu scn02
22298: cmpl r8,$ch$pl # else treat as semicolon unless plus
22299: beqlu 0f
22300: jmp scn30
22301: 0:
22302: #
22303: # HERE FOR CONTINUATION LINE
22304: #
22305: scn02: jsb nexts # acquire next source image
22306: movl $num01,scnpt # set scan pointer past continuation
22307: movl sp,scnbl # set blanks flag
22308: #page
22309: #
22310: # SCANE (CONTINUED)
22311: #
22312: # MERGE HERE TO SCAN NEXT ELEMENT ON CURRENT LINE
22313: #
22314: scn03: movl scnpt,r6 # load current offset
22315: cmpl r6,scnil # check continuation if end
22316: bnequ 0f
22317: jmp scn01
22318: 0:
22319: movl r$cim,r10 # point to current line
22320: movab cfp$f(r10)[r6],r10 # point to current character
22321: movl r6,scnse # set start of element location
22322: movl $opdvs,r8 # point to operator dv list
22323: movl $4*dvubs,r7 # set constant for operator circuit
22324: jmp scn06 # start scanning
22325: #
22326: # LOOP HERE TO IGNORE LEADING BLANKS AND TABS
22327: #
22328: scn05: tstl r7 # jump if trailing
22329: bnequ 0f
22330: jmp scn10
22331: 0:
22332: incl scnse # increment start of element
22333: cmpl r6,scnil # jump if end of image
22334: bnequ 0f
22335: jmp scn01
22336: 0:
22337: movl sp,scnbl # note blanks seen
22338: #
22339: # THE FOLLOWING JUMP IS USED REPEATEDLY FOR SCANNING OUT
22340: # THE CHARACTERS OF A NUMERIC CONSTANT OR VARIABLE NAME.
22341: # THE REGISTERS ARE USED AS FOLLOWS.
22342: #
22343: # (XR) SCRATCH
22344: # (XL) PTR TO NEXT CHARACTER
22345: # (WA) CURRENT SCAN OFFSET
22346: # (WB) *DVUBS (0 IF SCANNING NAME,CONST)
22347: # (WC) =OPDVS (0 IF SCANNING CONSTANT)
22348: #
22349: scn06: movzbl (r10)+,r9 # get next character
22350: incl r6 # bump scan offset
22351: movl r6,scnpt # store offset past char scanned
22352: cmpl $cfp$u,r9 # quick check for other char
22353: bgtru 0f
22354: jmp scn07
22355: 0:
22356: casel r9,$0,$cfp$u # switch on scanned character
22357: 5:
22358: #
22359: # SWITCH TABLE FOR SWITCH ON CHARACTER
22360: #
22361: #page
22362: #
22363: # SCANE (CONTINUED)
22364: #
22365: #page
22366: #
22367: # SCANE (CONTINUED)
22368: #
22369: .word scn07-5b
22370: .word scn07-5b
22371: .word scn07-5b
22372: .word scn07-5b
22373: .word scn07-5b
22374: .word scn07-5b
22375: .word scn07-5b
22376: .word scn07-5b
22377: .word scn07-5b
22378: .word scn05-5b # horizontal tab
22379: .word scn07-5b
22380: .word scn07-5b
22381: .word scn07-5b
22382: .word scn07-5b
22383: .word scn07-5b
22384: .word scn07-5b
22385: .word scn07-5b
22386: .word scn07-5b
22387: .word scn07-5b
22388: .word scn07-5b
22389: .word scn07-5b
22390: .word scn07-5b
22391: .word scn07-5b
22392: .word scn07-5b
22393: .word scn07-5b
22394: .word scn07-5b
22395: .word scn07-5b
22396: .word scn07-5b
22397: .word scn07-5b
22398: .word scn07-5b
22399: .word scn07-5b
22400: .word scn07-5b
22401: .word scn05-5b # blank
22402: .word scn37-5b # exclamation mark
22403: .word scn17-5b # double quote
22404: .word scn41-5b # number sign
22405: .word scn36-5b # dollar
22406: .word scn38-5b # percent
22407: .word scn44-5b # ampersand
22408: .word scn16-5b # single quote
22409: .word scn25-5b # left paren
22410: .word scn26-5b # right paren
22411: .word scn49-5b # asterisk
22412: .word scn33-5b # plus
22413: .word scn31-5b # comma
22414: .word scn34-5b # minus
22415: .word scn32-5b # dot
22416: .word scn40-5b # slash
22417: .word scn08-5b # digit 0
22418: .word scn08-5b # digit 1
22419: .word scn08-5b # digit 2
22420: .word scn08-5b # digit 3
22421: .word scn08-5b # digit 4
22422: .word scn08-5b # digit 5
22423: .word scn08-5b # digit 6
22424: .word scn08-5b # digit 7
22425: .word scn08-5b # digit 8
22426: .word scn08-5b # digit 9
22427: .word scn29-5b # colon
22428: .word scn30-5b # semi-colon
22429: .word scn28-5b # left bracket
22430: .word scn46-5b # equal
22431: .word scn27-5b # right bracket
22432: .word scn45-5b # question mark
22433: .word scn42-5b # at
22434: .word scn09-5b # letter a
22435: .word scn09-5b # letter b
22436: .word scn09-5b # letter c
22437: .word scn09-5b # letter d
22438: .word scn09-5b # letter e
22439: .word scn20-5b # letter f
22440: .word scn09-5b # letter g
22441: .word scn09-5b # letter h
22442: .word scn09-5b # letter i
22443: .word scn09-5b # letter j
22444: .word scn09-5b # letter k
22445: .word scn09-5b # letter l
22446: .word scn09-5b # letter m
22447: .word scn09-5b # letter n
22448: .word scn09-5b # letter o
22449: .word scn09-5b # letter p
22450: .word scn09-5b # letter q
22451: .word scn09-5b # letter r
22452: .word scn21-5b # letter s
22453: .word scn09-5b # letter t
22454: .word scn09-5b # letter u
22455: .word scn09-5b # letter v
22456: .word scn09-5b # letter w
22457: .word scn09-5b # letter x
22458: .word scn09-5b # letter y
22459: .word scn09-5b # letter z
22460: .word scn28-5b # left bracket
22461: .word scn07-5b
22462: .word scn27-5b # right bracket
22463: .word scn07-5b
22464: .word scn24-5b # underline
22465: .word scn07-5b
22466: .word scn09-5b # shifted a
22467: .word scn09-5b # shifted b
22468: .word scn09-5b # shifted c
22469: .word scn09-5b # shifted d
22470: .word scn09-5b # shifted e
22471: .word scn20-5b # shifted f
22472: .word scn09-5b # shifted g
22473: .word scn09-5b # shifted h
22474: .word scn09-5b # shifted i
22475: .word scn09-5b # shifted j
22476: .word scn09-5b # shifted k
22477: .word scn09-5b # shifted l
22478: .word scn09-5b # shifted m
22479: .word scn09-5b # shifted n
22480: .word scn09-5b # shifted o
22481: .word scn09-5b # shifted p
22482: .word scn09-5b # shifted q
22483: .word scn09-5b # shifted r
22484: .word scn21-5b # shifted s
22485: .word scn09-5b # shifted t
22486: .word scn09-5b # shifted u
22487: .word scn09-5b # shifted v
22488: .word scn09-5b # shifted w
22489: .word scn09-5b # shifted x
22490: .word scn09-5b # shifted y
22491: .word scn09-5b # shifted z
22492: .word scn07-5b
22493: .word scn43-5b # vertical bar
22494: .word scn07-5b
22495: .word scn35-5b # not
22496: .word scn07-5b
22497: #esw # end switch on character
22498: #
22499: # HERE FOR ILLEGAL CHARACTER (UNDERLINE MERGES)
22500: #
22501: scn07: tstl r7 # jump if scanning name or constant
22502: bnequ 0f
22503: jmp scn10
22504: 0:
22505: jmp er_230 # syntax error. illegal character
22506: #page
22507: #
22508: # SCANE (CONTINUED)
22509: #
22510: # HERE FOR DIGITS 0-9
22511: #
22512: scn08: tstl r7 # keep scanning if name/constant
22513: bnequ 0f
22514: jmp scn09
22515: 0:
22516: clrl r8 # else set flag for scanning constant
22517: #
22518: # HERE FOR LETTER. LOOP HERE WHEN SCANNING NAME/CONSTANT
22519: #
22520: scn09: cmpl r6,scnil # jump if end of image
22521: beqlu scn11
22522: clrl r7 # set flag for scanning name/const
22523: jmp scn06 # merge back to continue scan
22524: #
22525: # COME HERE FOR DELIMITER ENDING NAME OR CONSTANT
22526: #
22527: scn10: decl r6 # reset offset to point to delimiter
22528: #
22529: # COME HERE AFTER FINISHING SCAN OF NAME OR CONSTANT
22530: #
22531: scn11: movl r6,scnpt # store updated scan offset
22532: movl scnse,r7 # point to start of element
22533: subl2 r7,r6 # get number of characters
22534: movl r$cim,r10 # point to line image
22535: tstl r8 # jump if name
22536: bnequ scn15
22537: #
22538: # HERE AFTER SCANNING OUT NUMERIC CONSTANT
22539: #
22540: jsb sbstr # get string for constant
22541: movl r9,dnamp # delete from storage (not needed)
22542: jsb gtnum # convert to numeric
22543: .long scn14 # jump if conversion failure
22544: #
22545: # MERGE HERE TO EXIT WITH CONSTANT
22546: #
22547: scn12: movl $t$con,r10 # set result type of constant
22548: #page
22549: #
22550: # SCANE (CONTINUED)
22551: #
22552: # COMMON EXIT POINT (XR,XL) SET
22553: #
22554: scn13: movl scnsa,r6 # restore wa
22555: movl scnsb,r7 # restore wb
22556: movl scnsc,r8 # restore wc
22557: movl r9,r$scp # save xr in case rescan
22558: movl r10,scntp # save xl in case rescan
22559: clrl scngo # reset possible goto flag
22560: rsb # return to scane caller
22561: #
22562: # HERE IF CONVERSION ERROR ON NUMERIC ITEM
22563: #
22564: scn14: jmp er_231 # syntax error. invalid numeric item
22565: #
22566: # HERE AFTER SCANNING OUT VARIABLE NAME
22567: #
22568: scn15: jsb sbstr # build string name of variable
22569: tstl scncc # return if cncrd call
22570: beqlu 0f
22571: jmp scn13
22572: 0:
22573: jsb gtnvr # locate/build vrblk
22574: .long invalid$ # dummy (unused) error return
22575: movl $t$var,r10 # set type as variable
22576: jmp scn13 # back to exit
22577: #
22578: # HERE FOR SINGLE QUOTE (START OF STRING CONSTANT)
22579: #
22580: scn16: tstl r7 # terminator if scanning name or cnst
22581: bnequ 0f
22582: jmp scn10
22583: 0:
22584: movl $ch$sq,r7 # set terminator as single quote
22585: jmp scn18 # merge
22586: #
22587: # HERE FOR DOUBLE QUOTE (START OF STRING CONSTANT)
22588: #
22589: scn17: tstl r7 # terminator if scanning name or cnst
22590: bnequ 0f
22591: jmp scn10
22592: 0:
22593: movl $ch$dq,r7 # set double quote terminator, merge
22594: #
22595: # LOOP TO SCAN OUT STRING CONSTANT
22596: #
22597: scn18: cmpl r6,scnil # error if end of image
22598: beqlu scn19
22599: movzbl (r10)+,r8 # else load next character
22600: incl r6 # bump offset
22601: cmpl r8,r7 # loop back if not terminator
22602: bnequ scn18
22603: #page
22604: #
22605: # SCANE (CONTINUED)
22606: #
22607: # HERE AFTER SCANNING OUT STRING CONSTANT
22608: #
22609: movl scnpt,r7 # point to first character
22610: movl r6,scnpt # save offset past final quote
22611: decl r6 # point back past last character
22612: subl2 r7,r6 # get number of characters
22613: movl r$cim,r10 # point to input image
22614: jsb sbstr # build substring value
22615: jmp scn12 # back to exit with constant result
22616: #
22617: # HERE IF NO MATCHING QUOTE FOUND
22618: #
22619: scn19: movl r6,scnpt # set updated scan pointer
22620: jmp er_232 # syntax error. unmatched string quote
22621: #
22622: # HERE FOR F (POSSIBLE FAILURE GOTO)
22623: #
22624: scn20: movl $t$fgo,r9 # set return code for fail goto
22625: jmp scn22 # jump to merge
22626: #
22627: # HERE FOR S (POSSIBLE SUCCESS GOTO)
22628: #
22629: scn21: movl $t$sgo,r9 # set success goto as return code
22630: #
22631: # SPECIAL GOTO CASES MERGE HERE
22632: #
22633: scn22: tstl scngo # treat as normal letter if not goto
22634: bnequ 0f
22635: jmp scn09
22636: 0:
22637: #
22638: # MERGE HERE FOR SPECIAL CHARACTER EXIT
22639: #
22640: scn23: tstl r7 # jump if end of name/constant
22641: bnequ 0f
22642: jmp scn10
22643: 0:
22644: movl r9,r10 # else copy code
22645: jmp scn13 # and jump to exit
22646: #
22647: # HERE FOR UNDERLINE
22648: #
22649: scn24: tstl r7 # part of name if scanning name
22650: bnequ 0f
22651: jmp scn09
22652: 0:
22653: jmp scn07 # else illegal
22654: #page
22655: #
22656: # SCANE (CONTINUED)
22657: #
22658: # HERE FOR LEFT PAREN
22659: #
22660: scn25: movl $t$lpr,r9 # set left paren return code
22661: tstl r7 # return left paren unless name
22662: bnequ scn23
22663: tstl r8 # delimiter if scanning constant
22664: bnequ 0f
22665: jmp scn10
22666: 0:
22667: #
22668: # HERE FOR LEFT PAREN AFTER NAME (FUNCTION CALL)
22669: #
22670: movl scnse,r7 # point to start of name
22671: movl r6,scnpt # set pointer past left paren
22672: decl r6 # point back past last char of name
22673: subl2 r7,r6 # get name length
22674: movl r$cim,r10 # point to input image
22675: jsb sbstr # get string name for function
22676: jsb gtnvr # locate/build vrblk
22677: .long invalid$ # dummy (unused) error return
22678: movl $t$fnc,r10 # set code for function call
22679: jmp scn13 # back to exit
22680: #
22681: # PROCESSING FOR SPECIAL CHARACTERS
22682: #
22683: scn26: movl $t$rpr,r9 # right paren, set code
22684: jmp scn23 # take special character exit
22685: #
22686: scn27: movl $t$rbr,r9 # right bracket, set code
22687: jmp scn23 # take special character exit
22688: #
22689: scn28: movl $t$lbr,r9 # left bracket, set code
22690: jmp scn23 # take special character exit
22691: #
22692: scn29: movl $t$col,r9 # colon, set code
22693: jmp scn23 # take special character exit
22694: #
22695: scn30: movl $t$smc,r9 # semi-colon, set code
22696: jmp scn23 # take special character exit
22697: #
22698: scn31: movl $t$cma,r9 # comma, set code
22699: jmp scn23 # take special character exit
22700: #page
22701: #
22702: # SCANE (CONTINUED)
22703: #
22704: # HERE FOR OPERATORS. ON ENTRY, WC POINTS TO THE TABLE OF
22705: # OPERATOR DOPE VECTORS AND WB IS THE INCREMENT TO STEP
22706: # TO THE NEXT PAIR (BINARY/UNARY) OF DOPE VECTORS IN THE
22707: # LIST. ON REACHING SCN46, THE POINTER HAS BEEN ADJUSTED TO
22708: # POINT TO THE APPROPRIATE PAIR OF DOPE VECTORS.
22709: # THE FIRST THREE ENTRIES ARE SPECIAL SINCE THEY CAN OCCUR
22710: # AS PART OF A VARIABLE NAME (.) OR CONSTANT (.+-).
22711: #
22712: scn32: tstl r7 # dot can be part of name or constant
22713: bnequ 0f
22714: jmp scn09
22715: 0:
22716: addl2 r7,r8 # else bump pointer
22717: #
22718: scn33: tstl r8 # plus can be part of constant
22719: bnequ 0f
22720: jmp scn09
22721: 0:
22722: tstl r7 # plus cannot be part of name
22723: bnequ 0f
22724: jmp scn48
22725: 0:
22726: addl2 r7,r8 # else bump pointer
22727: #
22728: scn34: tstl r8 # minus can be part of constant
22729: bnequ 0f
22730: jmp scn09
22731: 0:
22732: tstl r7 # minus cannot be part of name
22733: bnequ 0f
22734: jmp scn48
22735: 0:
22736: addl2 r7,r8 # else bump pointer
22737: #
22738: scn35: addl2 r7,r8 # not
22739: scn36: addl2 r7,r8 # dollar
22740: scn37: addl2 r7,r8 # exclamation
22741: scn38: addl2 r7,r8 # percent
22742: scn39: addl2 r7,r8 # asterisk
22743: scn40: addl2 r7,r8 # slash
22744: scn41: addl2 r7,r8 # number sign
22745: scn42: addl2 r7,r8 # at sign
22746: scn43: addl2 r7,r8 # vertical bar
22747: scn44: addl2 r7,r8 # ampersand
22748: scn45: addl2 r7,r8 # question mark
22749: #
22750: # ALL OPERATORS COME HERE (EQUAL MERGES DIRECTLY)
22751: # (WC) POINTS TO THE BINARY/UNARY PAIR OF OPERATOR DVBLKS.
22752: #
22753: scn46: tstl r7 # operator terminates name/constant
22754: bnequ 0f
22755: jmp scn10
22756: 0:
22757: movl r8,r9 # else copy dv pointer
22758: movzbl (r10),r8 # load next character
22759: movl $t$bop,r10 # set binary op in case
22760: cmpl r6,scnil # should be binary if image end
22761: beqlu scn47
22762: cmpl r8,$ch$bl # should be binary if followed by blk
22763: beqlu scn47
22764: cmpl r8,$ch$ht # jump if horizontal tab
22765: beqlu scn47
22766: cmpl r8,$ch$sm # semicolon can immediately follow =
22767: beqlu scn47
22768: #
22769: # HERE FOR UNARY OPERATOR
22770: #
22771: addl2 $4*dvbs$,r9 # point to dv for unary op
22772: movl $t$uop,r10 # set type for unary operator
22773: cmpl scntp,$t$uok # ok unary if ok preceding element
22774: bgtru 0f
22775: jmp scn13
22776: 0:
22777: #page
22778: #
22779: # SCANE (CONTINUED)
22780: #
22781: # MERGE HERE TO REQUIRE PRECEDING BLANKS
22782: #
22783: scn47: tstl scnbl # all ok if preceding blanks, exit
22784: beqlu 0f
22785: jmp scn13
22786: 0:
22787: #
22788: # FAIL OPERATOR IN THIS POSITION
22789: #
22790: scn48: jmp er_233 # syntax error. invalid use of operator
22791: #
22792: # HERE FOR ASTERISK, COULD BE ** SUBSTITUTE FOR EXCLAMATION
22793: #
22794: scn49: tstl r7 # end of name if scanning name
22795: bnequ 0f
22796: jmp scn10
22797: 0:
22798: cmpl r6,scnil # not ** if * at image end
22799: beqlu scn39
22800: movl r6,r9 # else save offset past first *
22801: movl r6,scnof # save another copy
22802: movzbl (r10)+,r6 # load next character
22803: cmpl r6,$ch$as # not ** if next char not *
22804: bnequ scn50
22805: incl r9 # else step offset past second *
22806: cmpl r9,scnil # ok exclam if end of image
22807: beqlu scn51
22808: movzbl (r10),r6 # else load next character
22809: cmpl r6,$ch$bl # exclamation if blank
22810: beqlu scn51
22811: cmpl r6,$ch$ht # exclamation if horizontal tab
22812: beqlu scn51
22813: #
22814: # UNARY *
22815: #
22816: scn50: movl scnof,r6 # recover stored offset
22817: movl r$cim,r10 # point to line again
22818: movab cfp$f(r10)[r6],r10 # point to current char
22819: jmp scn39 # merge with unary *
22820: #
22821: # HERE FOR ** AS SUBSTITUTE FOR EXCLAMATION
22822: #
22823: scn51: movl r9,scnpt # save scan pointer past 2nd *
22824: movl r9,r6 # copy scan pointer
22825: jmp scn37 # merge with exclamation
22826: #enp # end procedure scane
22827: #page
22828: #
22829: # SCNGF -- SCAN GOTO FIELD
22830: #
22831: # SCNGF IS CALLED FROM CMPIL TO SCAN AND ANALYZE A GOTO
22832: # FIELD INCLUDING THE SURROUNDING BRACKETS OR PARENTHESES.
22833: # FOR A NORMAL GOTO, THE RESULT RETURNED IS EITHER A VRBLK
22834: # POINTER FOR A SIMPLE LABEL OPERAND, OR A POINTER TO AN
22835: # EXPRESSION TREE WITH A SPECIAL OUTER UNARY OPERATOR
22836: # (O$GOC). FOR A DIRECT GOTO, THE RESULT RETURNED IS A
22837: # POINTER TO AN EXPRESSION TREE WITH THE SPECIAL OUTER
22838: # UNARY OPERATOR O$GOD.
22839: #
22840: # JSR SCNGF CALL TO SCAN GOTO FIELD
22841: # (XR) RESULT (SEE ABOVE)
22842: # (XL,WA,WB,WC) DESTROYED
22843: #
22844: scngf: #prc # entry point
22845: jsb scane # scan initial element
22846: cmpl r10,$t$lpr # skip if left paren (normal goto)
22847: beqlu scng1
22848: cmpl r10,$t$lbr # skip if left bracket (direct goto)
22849: beqlu scng2
22850: jmp er_234 # syntax error. goto field incorrect
22851: #
22852: # HERE FOR LEFT PAREN (NORMAL GOTO)
22853: #
22854: scng1: movl $num01,r7 # set expan flag for normal goto
22855: jsb expan # analyze goto field
22856: movl $opdvn,r6 # point to opdv for complex goto
22857: cmpl r9,statb # jump if not in static (sgd15)
22858: blequ scng3
22859: cmpl r9,state # jump to exit if simple label name
22860: blequ scng4
22861: jmp scng3 # complex goto - merge
22862: #
22863: # HERE FOR LEFT BRACKET (DIRECT GOTO)
22864: #
22865: scng2: movl $num02,r7 # set expan flag for direct goto
22866: jsb expan # scan goto field
22867: movl $opdvd,r6 # set opdv pointer for direct goto
22868: #page
22869: #
22870: # SCNGF (CONTINUED)
22871: #
22872: # MERGE HERE TO BUILD OUTER UNARY OPERATOR BLOCK
22873: #
22874: scng3: movl r6,-(sp) # stack operator dv pointer
22875: movl r9,-(sp) # stack pointer to expression tree
22876: jsb expop # pop operator off
22877: movl (sp)+,r9 # reload new expression tree pointer
22878: #
22879: # COMMON EXIT POINT
22880: #
22881: scng4: rsb # return to caller
22882: #enp # end procedure scngf
22883: #page
22884: #
22885: # SETVR -- SET VRGET,VRSTO FIELDS OF VRBLK
22886: #
22887: # SETVR SETS THE PROPER VALUES IN THE VRGET AND VRSTO
22888: # FIELDS OF A VRBLK. IT IS CALLED WHENEVER TRBLKS ARE
22889: # ADDED OR SUBTRACTED (TRACE,STOPTR,INPUT,OUTPUT,DETACH)
22890: #
22891: # (XR) POINTER TO VRBLK
22892: # JSR SETVR CALL TO SET FIELDS
22893: # (XL,WA) DESTROYED
22894: #
22895: # NOTE THAT SETVR IGNORES THE CALL IF XR DOES NOT POINT
22896: # INTO THE STATIC REGION (I.E. IS SOME OTHER NAME BASE)
22897: #
22898: setvr: #prc # entry point
22899: cmpl r9,state # exit if not natural variable
22900: bgequ setv1
22901: #
22902: # HERE IF WE HAVE A VRBLK
22903: #
22904: movl r9,r10 # copy vrblk pointer
22905: movl $b$vrl,4*vrget(r9) # store normal get value
22906: cmpl 4*vrsto(r9),$b$vre # skip if protected variable
22907: beqlu setv1
22908: movl $b$vrs,4*vrsto(r9) # store normal store value
22909: movl 4*vrval(r10),r10# point to next entry on chain
22910: cmpl (r10),$b$trt # jump if end of trblk chain
22911: bnequ setv1
22912: movl $b$vra,4*vrget(r9) # store trapped routine address
22913: movl $b$vrv,4*vrsto(r9) # set trapped routine address
22914: #
22915: # MERGE HERE TO EXIT TO CALLER
22916: #
22917: setv1: rsb # return to setvr caller
22918: #enp # end procedure setvr
22919: #page
22920: #
22921: # SORTA -- SORT ARRAY
22922: #
22923: # ROUTINE TO SORT AN ARRAY OR TABLE ON SAME BASIS AS IN
22924: # SITBOL. A TABLE IS CONVERTED TO AN ARRAY, LEAVING TWO
22925: # DIMENSIONAL ARRAYS AND VECTORS AS CASES TO BE CONSIDERED.
22926: # WHOLE ROWS OF ARRAYS ARE PERMUTED ACCORDING TO THE
22927: # ORDERING OF THE KEYS THEY CONTAIN, AND THE STRIDE
22928: # REFERRED TO, IS THE THE LENGTH OF A ROW. IT IS ONE
22929: # FOR A VECTOR.
22930: # THE SORT USED IS HEAPSORT, FUNDAMENTALS OF DATA STRUCTURE
22931: # HOROWITZ AND SAHNI, PITMAN 1977, PAGE 347.
22932: # IT IS AN ORDER N*LOG(N) ALGORITHM. IN ORDER
22933: # TO MAKE IT STABLE, COMPARANDS MAY NOT COMPARE EQUAL. THIS
22934: # IS ACHIEVED BY SORTING A COPY ARRAY (REFERRED TO AS THE
22935: # SORT ARRAY) CONTAINING AT ITS HIGH ADDRESS END, BYTE
22936: # OFFSETS TO THE ROWS TO BE SORTED HELD IN THE ORIGINAL
22937: # ARRAY (REFERRED TO AS THE KEY ARRAY). SORTC, THE
22938: # COMPARISON ROUTINE, ACCESSES THE KEYS THROUGH THESE
22939: # OFFSETS AND IN THE CASE OF EQUALITY, RESOLVES IT BY
22940: # COMPARING THE OFFSETS THEMSELVES. THE SORT PERMUTES THE
22941: # OFFSETS WHICH ARE THEN USED IN A FINAL OPERATION TO COPY
22942: # THE ACTUAL ITEMS INTO THE NEW ARRAY IN SORTED ORDER.
22943: # REFERENCES TO ZEROTH ITEM ARE TO NOTIONAL ITEM
22944: # PRECEDING FIRST ACTUAL ITEM.
22945: # REVERSE SORTING FOR RSORT IS DONE BY HAVING THE LESS THAN
22946: # TEST FOR KEYS EFFECTIVELY BE REPLACED BY A
22947: # GREATER THAN TEST.
22948: #
22949: # 1(XS) FIRST ARG - ARRAY OR TABLE
22950: # 0(XS) 2ND ARG - INDEX OR PDTYPE NAME
22951: # (WA) 0 , NON-ZERO FOR SORT , RSORT
22952: # JSR SORTA CALL TO SORT ARRAY
22953: # (XR) SORTED ARRAY
22954: # (XL,WA,WB,WC) DESTROYED
22955: #page
22956: #
22957: # SORTA (CONTINUED)
22958: #
22959: .data 1
22960: sorta_s: .long 0
22961: .text 0
22962: sorta: movl (sp)+,sorta_s # entry point
22963: movl r6,srtsr # sort/rsort indicator
22964: movl $4*num01,srtst # default stride of 1
22965: clrl srtof # default zero offset to sort key
22966: movl $nulls,srtdf # clear datatype field name
22967: movl (sp)+,r$sxr # unstack argument 2
22968: movl (sp)+,r9 # get first argument
22969: jsb gtarr # convert to array
22970: .long srt16 # fail
22971: movl r9,-(sp) # stack ptr to resulting key array
22972: movl r9,-(sp) # another copy for copyb
22973: jsb copyb # get copy array for sorting into
22974: .long invalid$ # cant fail
22975: movl r9,-(sp) # stack pointer to sort array
22976: movl r$sxr,r9 # get second arg
22977: movl 4*1(sp),r10 # get ptr to key array
22978: cmpl (r10),$b$vct # jump if arblk
22979: bnequ srt02
22980: cmpl r9,$nulls # jump if null second arg
22981: beqlu srt01
22982: jsb gtnvr # get vrblk ptr for it
22983: .long er_257 # erroneous 2nd arg in sort/rsort of vector
22984: movl r9,srtdf # store datatype field name vrblk
22985: #
22986: # COMPUTE N AND OFFSET TO ITEM A(0) IN VECTOR CASE
22987: #
22988: srt01: movl $4*vclen,r8 # offset to a(0)
22989: movl $4*vcvls,r7 # offset to first item
22990: movl 4*vclen(r10),r6 # get block length
22991: subl2 $4*vcsi$,r6 # get no. of entries, n (in bytes)
22992: jmp srt04 # merge
22993: #
22994: # HERE FOR ARRAY
22995: #
22996: srt02: movl 4*ardim(r10),r5 # get possible dimension
22997: movl r5,r6 # convert to short integer
22998: moval 0[r6],r6 # further convert to baus
22999: movl $4*arvls,r7 # offset to first value if one
23000: movl $4*arpro,r8 # offset before values if one dim.
23001: cmpl 4*arndm(r10),$num01 # jump in fact if one dim.
23002: bnequ 0f
23003: jmp srt04
23004: 0:
23005: cmpl 4*arndm(r10),$num02 # fail unless two dimens
23006: beqlu 0f
23007: jmp srt16
23008: 0:
23009: movl 4*arlb2(r10),r5 # get lower bound 2 as default
23010: cmpl r9,$nulls # jump if default second arg
23011: beqlu srt03
23012: jsb gtint # convert to integer
23013: .long srt17 # fail
23014: movl 4*icval(r9),r5 # get actual integer value
23015: #page
23016: #
23017: # SORTA (CONTINUED)
23018: #
23019: # HERE WITH SORT COLUMN INDEX IN IA IN ARRAY CASE
23020: #
23021: srt03: subl2 4*arlb2(r10),r5 # subtract low bound
23022: bvc 0f
23023: jmp srt17
23024: 0:
23025: tstl r5 # fail if below low bound
23026: bgeq 0f
23027: jmp srt17
23028: 0:
23029: subl2 4*ardm2(r10),r5 # check against dimension
23030: blss 0f # fail if too large
23031: jmp srt17
23032: 0:
23033: addl2 4*ardm2(r10),r5 # restore value
23034: movl r5,r6 # get as small integer
23035: moval 0[r6],r6 # offset within row to key
23036: movl r6,srtof # keep offset
23037: movl 4*ardm2(r10),r5 # second dimension is row length
23038: movl r5,r6 # convert to short integer
23039: movl r6,r9 # copy row length
23040: moval 0[r6],r6 # convert to bytes
23041: movl r6,srtst # store as stride
23042: movl 4*ardim(r10),r5 # get number of rows
23043: movl r5,r6 # as a short integer
23044: moval 0[r6],r6 # convert n to baus
23045: movl 4*arlen(r10),r8 # offset past array end
23046: subl2 r6,r8 # adjust, giving space for n offsets
23047: subl2 $4,r8 # point to a(0)
23048: movl 4*arofs(r10),r7 # offset to word before first item
23049: addl2 $4,r7 # offset to first item
23050: #
23051: # SEPARATE PRE-PROCESSING FOR ARRAYS AND VECTORS DONE.
23052: # TO SIMPLIFY LATER KEY COMPARISONS, REMOVAL OF ANY TRBLK
23053: # TRAP BLOCKS FROM ENTRIES IN KEY ARRAY IS EFFECTED.
23054: #
23055: # (XL) = 1(XS) = POINTER TO KEY ARRAY
23056: # (XS) = POINTER TO SORT ARRAY
23057: # WA = NUMBER OF ITEMS, N (CONVERTED TO BYTES).
23058: # WB = OFFSET TO FIRST ITEM OF ARRAYS.
23059: # WC = OFFSET TO A(0)
23060: #
23061: srt04: cmpl r6,$4*num01 # return if only a single item
23062: bgtru 0f
23063: jmp srt15
23064: 0:
23065: movl r6,srtsn # store number of items (in baus)
23066: movl r8,srtso # store offset to a(0)
23067: movl 4*arlen(r10),r8 # length of array or vec (=vclen)
23068: addl2 r10,r8 # point past end of array or vector
23069: movl r7,srtsf # store offset to first row
23070: addl2 r7,r10 # point to first item in key array
23071: #
23072: # LOOP THROUGH ARRAY
23073: #
23074: srt05: movl (r10),r9 # get an entry
23075: #
23076: # HUNT ALONG TRBLK CHAIN
23077: #
23078: srt06: cmpl (r9),$b$trt # jump out if not trblk
23079: bnequ srt07
23080: movl 4*trval(r9),r9 # get value field
23081: jmp srt06 # loop
23082: #page
23083: #
23084: # SORTA (CONTINUED)
23085: #
23086: # XR IS VALUE FROM END OF CHAIN
23087: #
23088: srt07: movl r9,(r10)+ # store as array entry
23089: cmpl r10,r8 # loop if not done
23090: blssu srt05
23091: movl (sp),r10 # get adrs of sort array
23092: movl srtsf,r9 # initial offset to first key
23093: movl srtst,r7 # get stride
23094: addl2 srtso,r10 # offset to a(0)
23095: addl2 $4,r10 # point to a(1)
23096: movl srtsn,r8 # get n
23097: ashl $-2,r8,r8 # convert from bytes
23098: movl r8,srtnr # store as row count
23099: # loop counter
23100: #
23101: # STORE KEY OFFSETS AT TOP OF SORT ARRAY
23102: #
23103: srt08: movl r9,(r10)+ # store an offset
23104: addl2 r7,r9 # bump offset by stride
23105: sobgtr r8,srt08 # loop through rows
23106: #
23107: # PERFORM THE SORT ON OFFSETS IN SORT ARRAY.
23108: #
23109: # (SRTSN) NUMBER OF ITEMS TO SORT, N (BYTES)
23110: # (SRTSO) OFFSET TO A(0)
23111: #
23112: srt09: movl srtsn,r6 # get n
23113: movl srtnr,r8 # get number of rows
23114: ashl $-1,r8,r8 # i = n / 2 (wc=i, index into array)
23115: moval 0[r8],r8 # convert back to bytes
23116: #
23117: # LOOP TO FORM INITIAL HEAP
23118: #
23119: srt10: jsb sorth # sorth(i,n)
23120: subl2 $4,r8 # i = i - 1
23121: bnequ srt10 # loop if i gt 0
23122: movl r6,r8 # i = n
23123: #
23124: # SORTING LOOP. AT THIS POINT, A(1) IS THE LARGEST
23125: # ITEM, SINCE ALGORITHM INITIALISES IT AS, AND THEN MAINTAI
23126: # IT AS, ROOT OF TREE.
23127: #
23128: srt11: subl2 $4,r8 # i = i - 1 (n - 1 initially)
23129: beqlu srt12 # jump if done
23130: movl (sp),r9 # get sort array address
23131: addl2 srtso,r9 # point to a(0)
23132: movl r9,r10 # a(0) address
23133: addl2 r8,r10 # a(i) address
23134: movl 4*1(r10),r7 # copy a(i+1)
23135: movl 4*1(r9),4*1(r10)# move a(1) to a(i+1)
23136: movl r7,4*1(r9) # complete exchange of a(1), a(i+1)
23137: movl r8,r6 # n = i for sorth
23138: movl $4*num01,r8 # i = 1 for sorth
23139: jsb sorth # sorth(1,n)
23140: movl r6,r8 # restore wc
23141: jmp srt11 # loop
23142: #page
23143: #
23144: # SORTA (CONTINUED)
23145: #
23146: # OFFSETS HAVE BEEN PERMUTED INTO REQUIRED ORDER BY SORT.
23147: # COPY ARRAY ELEMENTS OVER THEM.
23148: #
23149: srt12: movl (sp),r10 # base adrs of key array
23150: movl r10,r8 # copy it
23151: addl2 srtso,r8 # offset of a(0)
23152: addl2 srtsf,r10 # adrs of first row of sort array
23153: movl srtst,r7 # get stride
23154: ashl $-2,r7,r7 # convert to words
23155: #
23156: # COPYING LOOP FOR SUCCESSIVE ITEMS. SORTED OFFSETS ARE
23157: # HELD AT END OF SORT ARRAY.
23158: #
23159: srt13: addl2 $4,r8 # adrs of next of sorted offsets
23160: movl r8,r9 # copy it for access
23161: movl (r9),r9 # get offset
23162: addl2 4*1(sp),r9 # add key array base adrs
23163: movl r7,r6 # get count of words in row
23164: #
23165: # COPY A COMPLETE ROW
23166: #
23167: srt14: movl (r9)+,(r10)+ # move a word
23168: sobgtr r6,srt14 # loop
23169: decl srtnr # decrement row count
23170: bnequ srt13 # repeat till all rows done
23171: #
23172: # RETURN POINT
23173: #
23174: srt15: movl (sp)+,r9 # pop result array ptr
23175: addl2 $4,sp # pop key array ptr
23176: clrl r$sxl # clear junk
23177: clrl r$sxr # clear junk
23178: jmp *sorta_s # return
23179: #
23180: # ERROR POINT
23181: #
23182: srt16: jmp er_256 # sort/rsort 1st arg not suitable array or table
23183: srt17: jmp er_258 # sort/rsort 2nd arg out of range or non-integer
23184: #enp # end procudure sorta
23185: #page
23186: #
23187: # SORTC -- COMPARE SORT KEYS
23188: #
23189: # COMPARE TWO SORT KEYS GIVEN THEIR OFFSETS. IF
23190: # EQUAL, COMPARE KEY OFFSETS TO GIVE STABLE SORT.
23191: # NOTE THAT IF SRTSR IS NON-ZERO (REQUEST FOR REVERSE
23192: # SORT), THE QUOTED RETURNS ARE INVERTED.
23193: # FOR OBJECTS OF DIFFERING DATATYPES, THE ENTRY POINT
23194: # IDENTIFICATIONS ARE COMPARED.
23195: #
23196: # (XL) BASE ADRS FOR KEYS
23197: # (WA) OFFSET TO KEY 1 ITEM
23198: # (WB) OFFSET TO KEY 2 ITEM
23199: # (SRTSR) ZERO/NON-ZERO FOR SORT/RSORT
23200: # (SRTOF) OFFSET WITHIN ROW TO COMPARANDS
23201: # JSR SORTC CALL TO COMPARE KEYS
23202: # PPM LOC KEY1 LESS THAN KEY2
23203: # NORMAL RETURN, KEY1 GT THAN KEY2
23204: # (XL,XR,WA,WB) DESTROYED
23205: #
23206: sortc: #prc # entry point
23207: movl r6,srts1 # save offset 1
23208: movl r7,srts2 # save offset 2
23209: movl r8,srtsc # save wc
23210: addl2 srtof,r10 # add offset to comparand field
23211: movl r10,r9 # copy base + offset
23212: addl2 r6,r10 # add key1 offset
23213: addl2 r7,r9 # add key2 offset
23214: movl (r10),r10 # get key1
23215: movl (r9),r9 # get key2
23216: cmpl srtdf,$nulls # jump if datatype field name used
23217: beqlu 0f
23218: jmp src11
23219: 0:
23220: #page
23221: #
23222: # SORTC (CONTINUED)
23223: #
23224: # MERGE AFTER DEALING WITH FIELD NAME. TRY FOR STRINGS.
23225: #
23226: src01: movl (r10),r8 # get type code
23227: cmpl r8,(r9) # skip if not same datatype
23228: bnequ src02
23229: cmpl r8,$b$scl # jump if both strings
23230: beqlu src09
23231: #
23232: # NOW TRY FOR NUMERIC
23233: #
23234: src02: movl r10,r$sxl # keep arg1
23235: movl r9,r$sxr # keep arg2
23236: movl r10,-(sp) # stack
23237: movl r9,-(sp) # args
23238: jsb acomp # compare objects
23239: .long src10 # not numeric
23240: .long src10 # not numeric
23241: .long src03 # key1 less
23242: .long src08 # keys equal
23243: .long src05 # key1 greater
23244: #
23245: # RETURN IF KEY1 SMALLER (SORT), GREATER (RSORT)
23246: #
23247: src03: tstl srtsr # jump if rsort
23248: bnequ src06
23249: #
23250: src04: movl srtsc,r8 # restore wc
23251: movl (sp)+,r11 # return
23252: jmp *(r11)+
23253: #
23254: # RETURN IF KEY1 GREATER (SORT), SMALLER (RSORT)
23255: #
23256: src05: tstl srtsr # jump if rsort
23257: bnequ src04
23258: #
23259: src06: movl srtsc,r8 # restore wc
23260: addl2 $4*1,(sp) # return
23261: rsb
23262: #
23263: # KEYS ARE OF SAME DATATYPE
23264: #
23265: src07: cmpl r10,r9 # item first created is less
23266: blssu src03
23267: cmpl r10,r9 # addresses rise in order of creation
23268: bgtru src05
23269: #
23270: # DROP THROUGH OR MERGE FOR IDENTICAL OR EQUAL OBJECTS
23271: #
23272: src08: cmpl srts1,srts2 # test offsets or key addrss instead
23273: blssu src04
23274: jmp src06 # offset 1 greater
23275: #page
23276: #
23277: # SORTC (CONTINUED)
23278: #
23279: # STRINGS
23280: #
23281: src09: movl r10,-(sp) # stack
23282: movl r9,-(sp) # args
23283: jsb lcomp # compare objects
23284: .long invalid$ # cant
23285: .long invalid$ # fail
23286: .long src03 # key1 less
23287: .long src08 # keys equal
23288: .long src05 # key1 greater
23289: #
23290: # ARITHMETIC COMPARISON FAILED - RECOVER ARGS
23291: #
23292: src10: movl r$sxl,r10 # get arg1
23293: movl r$sxr,r9 # get arg2
23294: movl (r10),r8 # get type of key1
23295: cmpl r8,(r9) # jump if keys of same type
23296: beqlu src07
23297: movl r8,r10 # get block type word
23298: movl (r9),r9 # get block type word
23299: movzwl -2(r10),r10 # entry point id for key1
23300: movzwl -2(r9),r9 # entry point id for key2
23301: cmpl r10,r9 # jump if key1 gt key2
23302: bgtru src05
23303: jmp src03 # key1 lt key2
23304: #
23305: # DATATYPE FIELD NAME USED
23306: #
23307: src11: jsb sortf # call routine to find field 1
23308: movl r10,-(sp) # stack item pointer
23309: movl r9,r10 # get key2
23310: jsb sortf # find field 2
23311: movl r10,r9 # place as key2
23312: movl (sp)+,r10 # recover key1
23313: jmp src01 # merge
23314: #enp # procedure sortc
23315: #page
23316: #
23317: # SORTF -- FIND FIELD FOR SORTC
23318: #
23319: # ROUTINE USED BY SORTC TO OBTAIN ITEM CORRESPONDING
23320: # TO A GIVEN FIELD NAME, IF THIS EXISTS, IN A PROGRAMMER
23321: # DEFINED OBJECT PASSED AS ARGUMENT.
23322: # IF SUCH A MATCH OCCURS, RECORD IS KEPT OF DATATYPE
23323: # NAME, FIELD NAME AND OFFSET TO FIELD IN ORDER TO
23324: # SHORT-CIRCUIT LATER SEARCHES ON SAME TYPE. NOTE THAT
23325: # DFBLKS ARE STORED IN STATIC AND HENCE CANNOT BE MOVED.
23326: #
23327: # (SRTDF) VRBLK POINTER OF FIELD NAME
23328: # (XL) POSSIBLE PDBLK POINTER
23329: # JSR SORTF CALL TO SEARCH FOR FIELD NAME
23330: # (XL) ITEM FOUND OR ORIGINAL PDBLK PTR
23331: # (WC) DESTROYED
23332: #
23333: sortf: #prc # entry point
23334: cmpl (r10),$b$pdt # return if not pdblk
23335: bnequ srtf3
23336: movl r9,-(sp) # keep xr
23337: movl srtfd,r9 # get possible former dfblk ptr
23338: beqlu srtf4 # jump if not
23339: cmpl r9,4*pddfp(r10) # jump if not right datatype
23340: bnequ srtf4
23341: cmpl srtdf,srtff # jump if not right field name
23342: bnequ srtf4
23343: addl2 srtfo,r10 # add offset to required field
23344: #
23345: # HERE WITH XL POINTING TO FOUND FIELD
23346: #
23347: srtf1: movl (r10),r10 # get item from field
23348: #
23349: # RETURN POINT
23350: #
23351: srtf2: movl (sp)+,r9 # restore xr
23352: #
23353: srtf3: rsb # return
23354: #page
23355: #
23356: # SORTF (CONTINUED)
23357: #
23358: # CONDUCT A SEARCH
23359: #
23360: srtf4: movl r10,r9 # copy original pointer
23361: movl 4*pddfp(r9),r9 # point to dfblk
23362: movl r9,srtfd # keep a copy
23363: movl 4*fargs(r9),r8 # get number of fields
23364: moval 0[r8],r8 # convert to bytes
23365: addl2 4*dflen(r9),r9 # point past last field
23366: #
23367: # LOOP TO FIND NAME IN PDFBLK
23368: #
23369: srtf5: subl2 $4,r8 # count down
23370: subl2 $4,r9 # point in front
23371: cmpl (r9),srtdf # skip out if found
23372: beqlu srtf6
23373: tstl r8 # loop
23374: bnequ srtf5
23375: jmp srtf2 # return - not found
23376: #
23377: # FOUND
23378: #
23379: srtf6: movl (r9),srtff # keep field name ptr
23380: addl2 $4*pdfld,r8 # add offset to first field
23381: movl r8,srtfo # store as field offset
23382: addl2 r8,r10 # point to field
23383: jmp srtf1 # return
23384: #enp # procedure sortf
23385: #page
23386: #
23387: # SORTH -- HEAP ROUTINE FOR SORTA
23388: #
23389: # THIS ROUTINE CONSTRUCTS A HEAP FROM ELEMENTS OF ARRAY, A.
23390: # IN THIS APPLICATION, THE ELEMENTS ARE OFFSETS TO KEYS IN
23391: # A KEY ARRAY.
23392: #
23393: # (XS) POINTER TO SORT ARRAY BASE
23394: # 1(XS) POINTER TO KEY ARRAY BASE
23395: # (WA) MAX ARRAY INDEX, N (IN BYTES)
23396: # (WC) OFFSET J IN A TO ROOT (IN *1 TO *N)
23397: # JSR SORTH CALL SORTH(J,N) TO MAKE HEAP
23398: # (XL,XR,WB) DESTROYED
23399: #
23400: .data 1
23401: sorth_s: .long 0
23402: .text 0
23403: sorth: movl (sp)+,sorth_s # entry point
23404: movl r6,srtsn # save n
23405: movl r8,srtwc # keep wc
23406: movl (sp),r10 # sort array base adrs
23407: addl2 srtso,r10 # add offset to a(0)
23408: addl2 r8,r10 # point to a(j)
23409: movl (r10),srtrt # get offset to root
23410: addl2 r8,r8 # double j - cant exceed n
23411: #
23412: # LOOP TO MOVE DOWN TREE USING DOUBLED INDEX J
23413: #
23414: srh01: cmpl r8,srtsn # done if j gt n
23415: bgtru srh03
23416: cmpl r8,srtsn # skip if j equals n
23417: beqlu srh02
23418: movl (sp),r9 # sort array base adrs
23419: movl 4*1(sp),r10 # key array base adrs
23420: addl2 srtso,r9 # point to a(0)
23421: addl2 r8,r9 # adrs of a(j)
23422: movl 4*1(r9),r6 # get a(j+1)
23423: movl (r9),r7 # get a(j)
23424: #
23425: # COMPARE SONS. (WA) RIGHT SON, (WB) LEFT SON
23426: #
23427: jsb sortc # compare keys - lt(a(j+1),a(j))
23428: .long srh02 # a(j+1) lt a(j)
23429: addl2 $4,r8 # point to greater son, a(j+1)
23430: #page
23431: #
23432: # SORTH (CONTINUED)
23433: #
23434: # COMPARE ROOT WITH GREATER SON
23435: #
23436: srh02: movl 4*1(sp),r10 # key array base adrs
23437: movl (sp),r9 # get sort array address
23438: addl2 srtso,r9 # adrs of a(0)
23439: movl r9,r7 # copy this adrs
23440: addl2 r8,r9 # adrs of greater son, a(j)
23441: movl (r9),r6 # get a(j)
23442: movl r7,r9 # point back to a(0)
23443: movl srtrt,r7 # get root
23444: jsb sortc # compare them - lt(a(j),root)
23445: .long srh03 # father exceeds sons - done
23446: movl (sp),r9 # get sort array adrs
23447: addl2 srtso,r9 # point to a(0)
23448: movl r9,r10 # copy it
23449: movl r8,r6 # copy j
23450: ashl $-2,r8,r8 # convert to words
23451: ashl $-1,r8,r8 # get j/2
23452: moval 0[r8],r8 # convert back to bytes
23453: addl2 r6,r10 # point to a(j)
23454: addl2 r8,r9 # adrs of a(j/2)
23455: movl (r10),(r9) # a(j/2) = a(j)
23456: movl r6,r8 # recover j
23457: addl2 r8,r8 # j = j*2. done if too big
23458: bvc 0f
23459: jmp srh03
23460: 0:
23461: jmp srh01 # loop
23462: #
23463: # FINISH BY COPYING ROOT OFFSET BACK INTO ARRAY
23464: #
23465: srh03: ashl $-2,r8,r8 # convert to words
23466: ashl $-1,r8,r8 # j = j/2
23467: moval 0[r8],r8 # convert back to bytes
23468: movl (sp),r9 # sort array adrs
23469: addl2 srtso,r9 # adrs of a(0)
23470: addl2 r8,r9 # adrs of a(j/2)
23471: movl srtrt,(r9) # a(j/2) = root
23472: movl srtsn,r6 # restore wa
23473: movl srtwc,r8 # restore wc
23474: jmp *sorth_s # return
23475: #enp # end procedure sorth
23476: #page
23477: #page
23478: #
23479: # TFIND -- LOCATE TABLE ELEMENT
23480: #
23481: # (XR) SUBSCRIPT VALUE FOR ELEMENT
23482: # (XL) POINTER TO TABLE
23483: # (WB) ZERO BY VALUE, NON-ZERO BY NAME
23484: # JSR TFIND CALL TO LOCATE ELEMENT
23485: # PPM LOC TRANSFER LOCATION IF ACCESS FAILS
23486: # (XR) ELEMENT VALUE (IF BY VALUE)
23487: # (XR) DESTROYED (IF BY NAME)
23488: # (XL,WA) TEBLK NAME (IF BY NAME)
23489: # (XL,WA) DESTROYED (IF BY VALUE)
23490: # (WC,RA) DESTROYED
23491: #
23492: # NOTE THAT IF A CALL BY VALUE SPECIFIES A NON-EXISTENT
23493: # SUBSCRIPT, NULL IS RETURNED WITHOUT BUILDING A NEW TEBLK.
23494: #
23495: tfind: #prc # entry point
23496: movl r7,-(sp) # save name/value indicator
23497: movl r9,-(sp) # save subscript value
23498: movl r10,-(sp) # save table pointer
23499: movl 4*tblen(r10),r6 # load length of tbblk
23500: ashl $-2,r6,r6 # convert to word count
23501: subl2 $tbbuk,r6 # get number of buckets
23502: movl r6,r5 # convert to integer value
23503: movl r5,tfnsi # save for later
23504: movl (r9),r10 # load first word of subscript
23505: movzwl -2(r10),r10 # load block entry id (bl$xx)
23506: casel r10,$0,$bl$$d # switch on block type
23507: 5:
23508: .word tfn00-5b
23509: .word tfn00-5b
23510: .word tfn00-5b
23511: .word tfn00-5b
23512: .word tfn02-5b # jump if integer
23513: .word tfn04-5b # jump if name
23514: .word tfn03-5b # jump if pattern
23515: .word tfn03-5b # jump if pattern
23516: .word tfn03-5b # jump if pattern
23517: .word tfn02-5b # real
23518: .word tfn05-5b # jump if string
23519: .word tfn00-5b
23520: .word tfn00-5b
23521: .word tfn00-5b
23522: .word tfn00-5b
23523: .word tfn00-5b
23524: .word tfn00-5b
23525: #esw # end switch on block type
23526: #
23527: # HERE FOR BLOCKS FOR WHICH WE USE THE SECOND WORD OF THE
23528: # BLOCK AS THE HASH SOURCE (SEE BLOCK FORMATS FOR DETAILS).
23529: #
23530: tfn00: movl 4*1(r9),r6 # load second word
23531: #
23532: # MERGE HERE WITH ONE WORD HASH SOURCE IN WA
23533: #
23534: tfn01: movl r6,r5 # convert to integer
23535: jmp tfn06 # jump to merge
23536: #page
23537: #
23538: # TFIND (CONTINUED)
23539: #
23540: # HERE FOR INTEGER OR REAL
23541: #
23542: tfn02: movl 4*1(r9),r5 # load value as hash source
23543: bgeq tfn06 # ok if positive or zero
23544: mnegl r5,r5 # make positive
23545: bvs tfn06
23546: jmp tfn06 # merge
23547: #
23548: # FOR PATTERN, USE FIRST WORD (PCODE) AS SOURCE
23549: #
23550: tfn03: movl (r9),r6 # load first word as hash source
23551: jmp tfn01 # merge back
23552: #
23553: # FOR NAME, USE OFFSET AS HASH SOURCE
23554: #
23555: tfn04: movl 4*nmofs(r9),r6 # load offset as hash source
23556: jmp tfn01 # merge back
23557: #
23558: # HERE FOR STRING
23559: #
23560: tfn05: jsb hashs # call routine to compute hash
23561: #
23562: # MERGE HERE WITH HASH SOURCE IN (IA)
23563: #
23564: tfn06: ashq $-32,r4,r4 # compute hash index by remaindering
23565: ediv tfnsi,r4,r11,r5
23566: movl r5,r8 # get as one word integer
23567: moval 0[r8],r8 # convert to byte offset
23568: movl (sp),r10 # get table ptr again
23569: addl2 r8,r10 # point to proper bucket
23570: movl 4*tbbuk(r10),r9 # load first teblk pointer
23571: cmpl r9,(sp) # jump if no teblks on chain
23572: beqlu tfn10
23573: #
23574: # LOOP THROUGH TEBLKS ON HASH CHAIN
23575: #
23576: tfn07: movl r9,r7 # save teblk pointer
23577: movl 4*tesub(r9),r9 # load subscript value
23578: movl 4*1(sp),r10 # load input argument subscript val
23579: jsb ident # compare them
23580: .long tfn08 # jump if equal (ident)
23581: #
23582: # HERE IF NO MATCH WITH THAT TEBLK
23583: #
23584: movl r7,r10 # restore teblk pointer
23585: movl 4*tenxt(r10),r9 # point to next teblk on chain
23586: cmpl r9,(sp) # jump if there is one
23587: bnequ tfn07
23588: #
23589: # HERE IF NO MATCH WITH ANY TEBLK ON CHAIN
23590: #
23591: movl $4*tenxt,r8 # set offset to link field (xl base)
23592: jmp tfn11 # jump to merge
23593: #page
23594: #
23595: # TFIND (CONTINUED)
23596: #
23597: # HERE WE HAVE FOUND A MATCHING ELEMENT
23598: #
23599: tfn08: movl r7,r10 # restore teblk pointer
23600: movl $4*teval,r6 # set teblk name offset
23601: movl 4*2(sp),r7 # restore name/value indicator
23602: bnequ tfn09 # jump if called by name
23603: jsb acess # else get value
23604: .long tfn12 # jump if reference fails
23605: clrl r7 # restore name/value indicator
23606: #
23607: # COMMON EXIT FOR ENTRY FOUND
23608: #
23609: tfn09: addl2 $4*num03,sp # pop stack entries
23610: addl2 $4*1,(sp) # return to tfind caller
23611: rsb
23612: #
23613: # HERE IF NO TEBLKS ON THE HASH CHAIN
23614: #
23615: tfn10: addl2 $4*tbbuk,r8 # get offset to bucket ptr
23616: movl (sp),r10 # set tbblk ptr as base
23617: #
23618: # MERGE HERE WITH (XL,WC) BASE,OFFSET OF FINAL LINK
23619: #
23620: tfn11: movl (sp),r9 # tbblk pointer
23621: movl 4*tbinv(r9),r9 # load default value in case
23622: movl 4*2(sp),r7 # load name/value indicator
23623: beqlu tfn09 # exit with default if value call
23624: #
23625: # HERE WE MUST BUILD A NEW TEBLK
23626: #
23627: movl $4*tesi$,r6 # set size of teblk
23628: jsb alloc # allocate teblk
23629: addl2 r8,r10 # point to hash link
23630: movl r9,(r10) # link new teblk at end of chain
23631: movl $b$tet,(r9) # store type word
23632: movl $nulls,4*teval(r9) # set null as initial value
23633: movl (sp)+,4*tenxt(r9)# set tbblk ptr to mark end of chain
23634: movl (sp)+,4*tesub(r9)# store subscript value
23635: addl2 $4,sp # pop past name/value indicator
23636: movl r9,r10 # copy teblk pointer (name base)
23637: movl $4*teval,r6 # set offset
23638: addl2 $4*1,(sp) # return to caller with new teblk
23639: rsb
23640: #
23641: # ACESS FAIL RETURN
23642: #
23643: tfn12: movl (sp)+,r11 # alternative return
23644: jmp *(r11)+
23645: #enp # end procedure tfind
23646: #page
23647: #
23648: # TRACE -- SET/RESET A TRACE ASSOCIATION
23649: #
23650: # THIS PROCEDURE IS SHARED BY TRACE AND STOPTR TO
23651: # EITHER INITIATE OR STOP A TRACE RESPECTIVELY.
23652: #
23653: # (XL) TRBLK PTR (TRACE) OR ZERO (STOPTR)
23654: # 1(XS) FIRST ARGUMENT (NAME)
23655: # 0(XS) SECOND ARGUMENT (TRACE TYPE)
23656: # JSR TRACE CALL TO SET/RESET TRACE
23657: # PPM LOC TRANSFER LOC IF 1ST ARG IS BAD NAME
23658: # PPM LOC TRANSFER LOC IF 2ND ARG IS BAD TYPE
23659: # (XS) POPPED
23660: # (XL,XR,WA,WB,WC,IA) DESTROYED
23661: #
23662: .data 1
23663: trace_s: .long 0
23664: .text 0
23665: trace: movl (sp)+,trace_s # entry point
23666: jsb gtstg # get trace type string
23667: .long trc15 # jump if not string
23668: movab cfp$f(r9),r9 # else point to string
23669: movzbl (r9),r6 # load first character
23670: bicl2 $ch$bl,r6 # fold to upper case
23671: movl (sp),r9 # load name argument
23672: movl r10,(sp) # stack trblk ptr or zero
23673: movl $trtac,r8 # set trtyp for access trace
23674: cmpl r6,$ch$la # jump if a (access)
23675: bnequ 0f
23676: jmp trc10
23677: 0:
23678: movl $trtvl,r8 # set trtyp for value trace
23679: cmpl r6,$ch$lv # jump if v (value)
23680: bnequ 0f
23681: jmp trc10
23682: 0:
23683: tstl r6 # jump if blank (value)
23684: bnequ 0f
23685: jmp trc10
23686: 0:
23687: #
23688: # HERE FOR L,K,F,C,R
23689: #
23690: cmpl r6,$ch$lf # jump if f (function)
23691: beqlu trc01
23692: cmpl r6,$ch$lr # jump if r (return)
23693: beqlu trc01
23694: cmpl r6,$ch$ll # jump if l (label)
23695: beqlu trc03
23696: cmpl r6,$ch$lk # jump if k (keyword)
23697: bnequ 0f
23698: jmp trc06
23699: 0:
23700: cmpl r6,$ch$lc # else error if not c (call)
23701: beqlu 0f
23702: jmp trc15
23703: 0:
23704: #
23705: # HERE FOR F,C,R
23706: #
23707: trc01: jsb gtnvr # point to vrblk for name
23708: .long trc16 # jump if bad name
23709: addl2 $4,sp # pop stack
23710: movl 4*vrfnc(r9),r9 # point to function block
23711: cmpl (r9),$b$pfc # error if not program function
23712: beqlu 0f
23713: jmp trc17
23714: 0:
23715: cmpl r6,$ch$lr # jump if r (return)
23716: beqlu trc02
23717: #page
23718: #
23719: # TRACE (CONTINUED)
23720: #
23721: # HERE FOR F,C TO SET/RESET CALL TRACE
23722: #
23723: movl r10,4*pfctr(r9) # set/reset call trace
23724: cmpl r6,$ch$lc # exit with null if c (call)
23725: bnequ 0f
23726: jmp exnul
23727: 0:
23728: #
23729: # HERE FOR F,R TO SET/RESET RETURN TRACE
23730: #
23731: trc02: movl r10,4*pfrtr(r9) # set/reset return trace
23732: addl3 $4*2,trace_s,r11 # return
23733: jmp (r11)
23734: #
23735: # HERE FOR L TO SET/RESET LABEL TRACE
23736: #
23737: trc03: jsb gtnvr # point to vrblk
23738: .long trc16 # jump if bad name
23739: movl 4*vrlbl(r9),r10 # load label pointer
23740: cmpl (r10),$b$trt # jump if no old trace
23741: bnequ trc04
23742: movl 4*trlbl(r10),r10# else delete old trace association
23743: #
23744: # HERE WITH OLD LABEL TRACE ASSOCIATION DELETED
23745: #
23746: trc04: cmpl r10,$stndl # error if undefined label
23747: bnequ 0f
23748: jmp trc16
23749: 0:
23750: movl (sp)+,r7 # get trblk ptr again
23751: beqlu trc05 # jump if stoptr case
23752: movl r7,4*vrlbl(r9) # else set new trblk pointer
23753: movl $b$vrt,4*vrtra(r9) # set label trace routine address
23754: movl r7,r9 # copy trblk pointer
23755: movl r10,4*trlbl(r9) # store real label in trblk
23756: addl3 $4*2,trace_s,r11 # return
23757: jmp (r11)
23758: #
23759: # HERE FOR STOPTR CASE FOR LABEL
23760: #
23761: trc05: movl r10,4*vrlbl(r9) # store label ptr back in vrblk
23762: movl $b$vrg,4*vrtra(r9) # store normal transfer address
23763: addl3 $4*2,trace_s,r11 # return
23764: jmp (r11)
23765: #page
23766: #
23767: # TRACE (CONTINUED)
23768: #
23769: # HERE FOR K (KEYWORD)
23770: #
23771: trc06: jsb gtnvr # point to vrblk
23772: .long trc16 # error if not natural var
23773: tstl 4*vrlen(r9) # error if not system var
23774: beqlu 0f
23775: jmp trc16
23776: 0:
23777: addl2 $4,sp # pop stack
23778: tstl r10 # jump if stoptr case
23779: beqlu trc07
23780: movl r9,4*trkvr(r10) # store vrblk ptr in trblk for ktrex
23781: #
23782: # MERGE HERE WITH TRBLK SET UP IN WB (OR ZERO)
23783: #
23784: trc07: movl 4*vrsvp(r9),r9 # point to svblk
23785: cmpl r9,$v$ert # jump if errtype
23786: beqlu trc08
23787: cmpl r9,$v$stc # jump if stcount
23788: beqlu trc09
23789: cmpl r9,$v$fnc # else error if not fnclevel
23790: beqlu 0f
23791: jmp trc17
23792: 0:
23793: #
23794: # FNCLEVEL
23795: #
23796: movl r10,r$fnc # set/reset fnclevel trace
23797: addl3 $4*2,trace_s,r11 # return
23798: jmp (r11)
23799: #
23800: # ERRTYPE
23801: #
23802: trc08: movl r10,r$ert # set/reset errtype trace
23803: addl3 $4*2,trace_s,r11 # return
23804: jmp (r11)
23805: #
23806: # STCOUNT
23807: #
23808: trc09: movl r10,r$stc # set/reset stcount trace
23809: addl3 $4*2,trace_s,r11 # return
23810: jmp (r11)
23811: #page
23812: #
23813: # TRACE (CONTINUED)
23814: #
23815: # A,V MERGE HERE WITH TRTYP VALUE IN WC
23816: #
23817: trc10: jsb gtvar # locate variable
23818: .long trc16 # error if not appropriate name
23819: movl (sp)+,r7 # get new trblk ptr again
23820: addl2 r10,r6 # point to variable location
23821: movl r6,r9 # copy variable pointer
23822: #
23823: # LOOP TO SEARCH TRBLK CHAIN
23824: #
23825: trc11: movl (r9),r10 # point to next entry
23826: cmpl (r10),$b$trt # jump if not trblk
23827: bnequ trc13
23828: cmpl r8,4*trtyp(r10) # jump if too far out on chain
23829: blssu trc13
23830: cmpl r8,4*trtyp(r10) # jump if this matches our type
23831: beqlu trc12
23832: addl2 $4*trnxt,r10 # else point to link field
23833: movl r10,r9 # copy pointer
23834: jmp trc11 # and loop back
23835: #
23836: # HERE TO DELETE AN OLD TRBLK OF THE TYPE WE WERE GIVEN
23837: #
23838: trc12: movl 4*trnxt(r10),r10# get ptr to next block or value
23839: movl r10,(r9) # store to delete this trblk
23840: #
23841: # HERE AFTER DELETING ANY OLD ASSOCIATION OF THIS TYPE
23842: #
23843: trc13: tstl r7 # jump if stoptr case
23844: beqlu trc14
23845: movl r7,(r9) # else link new trblk in
23846: movl r7,r9 # copy trblk pointer
23847: movl r10,4*trnxt(r9) # store forward pointer
23848: movl r8,4*trtyp(r9) # store appropriate trap type code
23849: #
23850: # HERE TO MAKE SURE VRGET,VRSTO ARE SET PROPERLY
23851: #
23852: trc14: movl r6,r9 # recall possible vrblk pointer
23853: subl2 $4*vrval,r9 # point back to vrblk
23854: jsb setvr # set fields if vrblk
23855: addl3 $4*2,trace_s,r11 # return
23856: jmp (r11)
23857: #
23858: # HERE FOR BAD TRACE TYPE
23859: #
23860: trc15: addl3 $4*1,trace_s,r11 # take bad trace type error exit
23861: jmp *(r11)+
23862: #
23863: # POP STACK BEFORE FAILING
23864: #
23865: trc16: addl2 $4,sp # pop stack
23866: #
23867: # HERE FOR BAD NAME ARGUMENT
23868: #
23869: trc17: movl trace_s,r11 # take bad name error exit
23870: jmp *(r11)+
23871: #enp # end procedure trace
23872: #page
23873: #
23874: # TRBLD -- BUILD TRBLK
23875: #
23876: # TRBLK IS USED BY THE INPUT, OUTPUT AND TRACE FUNCTIONS
23877: # TO CONSTRUCT A TRBLK (TRAP BLOCK)
23878: #
23879: # (XR) TRTAG OR TRTER
23880: # (XL) TRFNC OR TRFPT
23881: # (WB) TRTYP
23882: # JSR TRBLD CALL TO BUILD TRBLK
23883: # (XR) POINTER TO TRBLK
23884: # (WA) DESTROYED
23885: #
23886: trbld: #prc # entry point
23887: movl r9,-(sp) # stack trtag (or trfnm)
23888: movl $4*trsi$,r6 # set size of trblk
23889: jsb alloc # allocate trblk
23890: movl $b$trt,(r9) # store first word
23891: movl r10,4*trfnc(r9) # store trfnc (or trfpt)
23892: movl (sp)+,4*trtag(r9)# store trtag (or trfnm)
23893: movl r7,4*trtyp(r9) # store type
23894: movl $nulls,4*trval(r9) # for now, a null value
23895: rsb # return to caller
23896: #enp # end procedure trbld
23897: #page
23898: #
23899: # TRIMR -- TRIM TRAILING BLANKS
23900: #
23901: # TRIMR IS PASSED A POINTER TO AN SCBLK WHICH MUST BE THE
23902: # LAST BLOCK IN DYNAMIC STORAGE. TRAILING BLANKS ARE
23903: # TRIMMED OFF AND THE DYNAMIC STORAGE POINTER RESET TO
23904: # THE END OF THE (POSSIBLY) SHORTENED BLOCK.
23905: #
23906: # (WB) NON-ZERO TO TRIM TRAILING BLANKS
23907: # (XR) POINTER TO STRING TO TRIM
23908: # JSR TRIMR CALL TO TRIM STRING
23909: # (XR) POINTER TO TRIMMED STRING
23910: # (XL,WA,WB,WC) DESTROYED
23911: #
23912: # THE CALL WITH WB ZERO STILL PERFORMS THE END ZERO PAD
23913: # AND DNAMP READJUSTMENT. IT IS USED FROM ACESS IF KVTRM=0.
23914: #
23915: trimr: #prc # entry point
23916: movl r9,r10 # copy string pointer
23917: movl 4*sclen(r9),r6 # load string length
23918: beqlu trim2 # jump if null input
23919: movab cfp$f(r10)[r6],r10 # else point past last character
23920: tstl r7 # jump if no trim
23921: beqlu trim3
23922: movl $ch$bl,r8 # load blank character
23923: #
23924: # LOOP THROUGH CHARACTERS FROM RIGHT TO LEFT
23925: #
23926: trim0: movzbl -(r10),r7 # load next character
23927: cmpl r7,$ch$ht # jump if horizontal tab
23928: beqlu trim1
23929: cmpl r7,r8 # jump if non-blank found
23930: bnequ trim3
23931: trim1: decl r6 # else decrement character count
23932: bnequ trim0 # loop back if more to check
23933: #
23934: # HERE IF RESULT IS NULL (NULL OR ALL-BLANK INPUT)
23935: #
23936: trim2: movl r9,dnamp # wipe out input string block
23937: movl $nulls,r9 # load null result
23938: jmp trim5 # merge to exit
23939: #page
23940: #
23941: # TRIMR (CONTINUED)
23942: #
23943: # HERE WITH NON-BLANK FOUND (MERGE FOR NO TRIM)
23944: #
23945: trim3: movl r6,4*sclen(r9) # set new length
23946: movl r9,r10 # copy string pointer
23947: movab cfp$f(r10)[r6],r10 # ready for storing blanks
23948: movab 3+(4*schar)(r6),r6 # get length of block in bytes
23949: bicl2 $3,r6
23950: addl2 r9,r6 # point past new block
23951: movl r6,dnamp # set new top of storage pointer
23952: movl $cfp$c,r6 # get count of chars in word
23953: clrl r8 # set blank char
23954: #
23955: # LOOP TO ZERO PAD LAST WORD OF CHARACTERS
23956: #
23957: trim4: movb r8,(r10)+ # store zero character
23958: sobgtr r6,trim4 # loop back till all stored
23959: #csc r10 # complete store characters
23960: #
23961: # COMMON EXIT POINT
23962: #
23963: trim5: clrl r10 # clear garbage xl pointer
23964: rsb # return to caller
23965: #enp # end procedure trimr
23966: #page
23967: #
23968: # TRXEQ -- EXECUTE FUNCTION TYPE TRACE
23969: #
23970: # TRXEQ IS USED TO EXECUTE A TRACE WHEN A FOURTH ARGUMENT
23971: # HAS BEEN SUPPLIED. TRACE HAS ALREADY BEEN DECREMENTED.
23972: #
23973: # (XR) POINTER TO TRBLK
23974: # (XL,WA) NAME BASE,OFFSET FOR VARIABLE
23975: # JSR TRXEQ CALL TO EXECUTE TRACE
23976: # (WB,WC,RA) DESTROYED
23977: #
23978: # THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING
23979: # CONTROL TO THE TRACE FUNCTION USING THE CFUNC ROUTINE.
23980: #
23981: # TRXEQ RETURN POINT WORD(S)
23982: # SAVED VALUE OF TRACE KEYWORD
23983: # TRBLK POINTER
23984: # NAME BASE
23985: # NAME OFFSET
23986: # SAVED VALUE OF R$COD
23987: # SAVED CODE PTR (-R$COD)
23988: # SAVED VALUE OF FLPTR
23989: # FLPTR --------------- ZERO (DUMMY FAIL OFFSET)
23990: # NMBLK FOR VARIABLE NAME
23991: # XS ------------------ TRACE TAG
23992: #
23993: # R$COD AND THE CODE PTR ARE SET TO DUMMY VALUES WHICH
23994: # CAUSE CONTROL TO RETURN TO THE TRXEQ PROCEDURE ON SUCCESS
23995: # OR FAILURE (TRXEQ IGNORES A FAILURE CONDITION).
23996: #
23997: trxeq: #prc # entry point (recursive)
23998: movl r$cod,r8 # load code block pointer
23999: movl r3,r7 # get current code pointer
24000: subl2 r8,r7 # make code pointer into offset
24001: movl kvtra,-(sp) # stack trace keyword value
24002: movl r9,-(sp) # stack trblk pointer
24003: movl r10,-(sp) # stack name base
24004: movl r6,-(sp) # stack name offset
24005: movl r8,-(sp) # stack code block pointer
24006: movl r7,-(sp) # stack code pointer offset
24007: movl flptr,-(sp) # stack old failure pointer
24008: clrl -(sp) # set dummy fail offset
24009: movl sp,flptr # set new failure pointer
24010: clrl kvtra # reset trace keyword to zero
24011: movl $trxdc,r8 # load new (dummy) code blk pointer
24012: movl r8,r$cod # set as code block pointer
24013: movl r8,r3 # and new code pointer
24014: #page
24015: #
24016: # TRXEQ (CONTINUED)
24017: #
24018: # NOW PREPARE ARGUMENTS FOR FUNCTION
24019: #
24020: movl r6,r7 # save name offset
24021: movl $4*nmsi$,r6 # load nmblk size
24022: jsb alloc # allocate space for nmblk
24023: movl $b$nml,(r9) # set type word
24024: movl r10,4*nmbas(r9) # store name base
24025: movl r7,4*nmofs(r9) # store name offset
24026: movl 4*6(sp),r10 # reload pointer to trblk
24027: movl r9,-(sp) # stack nmblk pointer (1st argument)
24028: movl 4*trtag(r10),-(sp) # stack trace tag (2nd argument)
24029: movl 4*trfnc(r10),r10# load trace function pointer
24030: movl $num02,r6 # set number of arguments to two
24031: jmp cfunc # jump to call function
24032: #
24033: # SEE O$TXR FOR DETAILS OF RETURN TO THIS POINT
24034: #
24035: trxq1: movl flptr,sp # point back to our stack entries
24036: addl2 $4,sp # pop off garbage fail offset
24037: movl (sp)+,flptr # restore old failure pointer
24038: movl (sp)+,r7 # reload code offset
24039: movl (sp)+,r8 # load old code base pointer
24040: movl r8,r9 # copy cdblk pointer
24041: movl 4*cdstm(r9),kvstn# restore stmnt no
24042: movl (sp)+,r6 # reload name offset
24043: movl (sp)+,r10 # reload name base
24044: movl (sp)+,r9 # reload trblk pointer
24045: movl (sp)+,kvtra # restore trace keyword value
24046: addl2 r8,r7 # recompute absolute code pointer
24047: movl r7,r3 # restore code pointer
24048: movl r8,r$cod # and code block pointer
24049: rsb # return to trxeq caller
24050: #enp # end procedure trxeq
24051: #page
24052: #
24053: # XSCAN -- EXECUTION FUNCTION ARGUMENT SCAN
24054: #
24055: # XSCAN SCANS OUT ONE TOKEN IN A PROTOTYPE ARGUMENT IN
24056: # ARRAY,CLEAR,DATA,DEFINE,LOAD FUNCTION CALLS. XSCAN
24057: # CALLS MUST BE PRECEDED BY A CALL TO THE INITIALIZATION
24058: # PROCEDURE XSCNI. THE FOLLOWING VARIABLES ARE USED.
24059: #
24060: # R$XSC POINTER TO SCBLK FOR FUNCTION ARG
24061: # XSOFS OFFSET (NUM CHARS SCANNED SO FAR)
24062: #
24063: # (WC) DELIMITER ONE (CH$XX)
24064: # (XL) DELIMITER TWO (CH$XX)
24065: # JSR XSCAN CALL TO SCAN NEXT ITEM
24066: # (XR) POINTER TO SCBLK FOR TOKEN SCANNED
24067: # (WA) COMPLETION CODE (SEE BELOW)
24068: # (WC,XL) DESTROYED
24069: #
24070: # THE SCAN STARTS FROM THE CURRENT POSITION AND CONTINUES
24071: # UNTIL ONE OF THE FOLLOWING THREE CONDITIONS OCCURS.
24072: #
24073: # 1) DELIMITER ONE IS ENCOUNTERED (WA SET TO 1)
24074: #
24075: # 2) DELIMITER TWO ENCOUNTERED (WA SET TO 2)
24076: #
24077: # 3) END OF STRING ENCOUNTERED (WA SET TO 0)
24078: #
24079: # THE RESULT IS A STRING CONTAINING ALL CHARACTERS SCANNED
24080: # UP TO BUT NOT INCLUDING ANY DELIMITER CHARACTER.
24081: # THE POINTER IS LEFT POINTING PAST THE DELIMITER.
24082: #
24083: # IF ONLY ONE DELIMITER IS TO BE DETECTED, DELIMITER ONE
24084: # AND DELIMITER TWO SHOULD BE SET TO THE SAME VALUE.
24085: #
24086: # IN THE CASE WHERE THE END OF STRING IS ENCOUNTERED, THE
24087: # STRING INCLUDES ALL THE CHARACTERS TO THE END OF THE
24088: # STRING. NO FURTHER CALLS CAN BE MADE TO XSCAN UNTIL
24089: # XSCNI IS CALLED TO INITIALIZE A NEW ARGUMENT SCAN
24090: #page
24091: #
24092: # XSCAN (CONTINUED)
24093: #
24094: xscan: #prc # entry point
24095: movl r7,xscwb # preserve wb
24096: movl r$xsc,r9 # point to argument string
24097: movl 4*sclen(r9),r6 # load string length
24098: movl xsofs,r7 # load current offset
24099: subl2 r7,r6 # get number of remaining characters
24100: beqlu xscn2 # jump if no characters left
24101: movab cfp$f(r9)[r7],r9# point to current character
24102: #
24103: # LOOP TO SEARCH FOR DELIMITER
24104: #
24105: xscn1: movzbl (r9)+,r7 # load next character
24106: cmpl r7,r8 # jump if delimiter one found
24107: beqlu xscn3
24108: cmpl r7,r10 # jump if delimiter two found
24109: beqlu xscn4
24110: decl r6 # decrement count of chars left
24111: bnequ xscn1 # loop back if more chars to go
24112: #
24113: # HERE FOR RUNOUT
24114: #
24115: xscn2: movl r$xsc,r10 # point to string block
24116: movl 4*sclen(r10),r6 # get string length
24117: movl xsofs,r7 # load offset
24118: subl2 r7,r6 # get substring length
24119: clrl r$xsc # clear string ptr for collector
24120: clrl xscrt # set zero (runout) return code
24121: jmp xscn6 # jump to exit
24122: #page
24123: #
24124: # XSCAN (CONTINUED)
24125: #
24126: # HERE IF DELIMITER ONE FOUND
24127: #
24128: xscn3: movl $num01,xscrt # set return code
24129: jmp xscn5 # jump to merge
24130: #
24131: # HERE IF DELIMITER TWO FOUND
24132: #
24133: xscn4: movl $num02,xscrt # set return code
24134: #
24135: # MERGE HERE AFTER DETECTING A DELIMITER
24136: #
24137: xscn5: movl r$xsc,r10 # reload pointer to string
24138: movl 4*sclen(r10),r8 # get original length of string
24139: subl2 r6,r8 # minus chars left = chars scanned
24140: movl r8,r6 # move to reg for sbstr
24141: movl xsofs,r7 # set offset
24142: subl2 r7,r6 # compute length for sbstr
24143: incl r8 # adjust new cursor past delimiter
24144: movl r8,xsofs # store new offset
24145: #
24146: # COMMON EXIT POINT
24147: #
24148: xscn6: clrl r9 # clear garbage character ptr in xr
24149: jsb sbstr # build sub-string
24150: movl xscrt,r6 # load return code
24151: movl xscwb,r7 # restore wb
24152: rsb # return to xscan caller
24153: #enp # end procedure xscan
24154: #page
24155: #
24156: # XSCNI -- EXECUTION FUNCTION ARGUMENT SCAN
24157: #
24158: # XSCNI INITIALIZES THE SCAN USED FOR PROTOTYPE ARGUMENTS
24159: # IN THE CLEAR, DEFINE, LOAD, DATA, ARRAY FUNCTIONS. SEE
24160: # XSCAN FOR THE PROCEDURE WHICH IS USED AFTER THIS CALL.
24161: #
24162: # -(XS) ARGUMENT TO BE SCANNED (ON STACK)
24163: # JSR XSCNI CALL TO SCAN ARGUMENT
24164: # PPM LOC TRANSFER LOC IF ARG IS NOT STRING
24165: # PPM LOC TRANSFER LOC IF ARGUMENT IS NULL
24166: # (XS) POPPED
24167: # (XR,R$XSC) ARGUMENT (SCBLK PTR)
24168: # (WA) ARGUMENT LENGTH
24169: # (IA,RA) DESTROYED
24170: #
24171: .data 1
24172: xscni_s: .long 0
24173: .text 0
24174: xscni: movl (sp)+,xscni_s # entry point
24175: jsb gtstg # fetch argument as string
24176: .long xsci1 # jump if not convertible
24177: movl r9,r$xsc # else store scblk ptr for xscan
24178: clrl xsofs # set offset to zero
24179: tstl r6 # jump if null string
24180: beqlu xsci2
24181: addl3 $4*2,xscni_s,r11 # return to xscni caller
24182: jmp (r11)
24183: #
24184: # HERE IF ARGUMENT IS NOT A STRING
24185: #
24186: xsci1: movl xscni_s,r11 # take not-string error exit
24187: jmp *(r11)+
24188: #
24189: # HERE FOR NULL STRING
24190: #
24191: xsci2: addl3 $4*1,xscni_s,r11 # take null-string error exit
24192: jmp *(r11)+
24193: #enp # end procedure xscni
24194: #title s p i t b o l -- utility routines
24195: #
24196: # THE FOLLOWING SECTION CONTAINS UTILITY ROUTINES USED FOR
24197: # VARIOUS PURPOSES THROUGHOUT THE SYSTEM. THESE DIFFER
24198: # FROM THE PROCEDURES IN THE UTILITY PROCEDURES SECTION IN
24199: # THEY ARE NOT IN PROCEDURE FORM AND THEY DO NOT RETURN
24200: # TO THEIR CALLERS. THEY ARE ACCESSED WITH A BRANCH TYPE
24201: # INSTRUCTION AFTER SETTING THE REGISTERS TO APPROPRIATE
24202: # PARAMETER VALUES.
24203: #
24204: # THE REGISTER VALUES REQUIRED FOR EACH ROUTINE ARE
24205: # DOCUMENTED AT THE START OF EACH ROUTINE. REGISTERS NOT
24206: # MENTIONED MAY CONTAIN ANY VALUES EXCEPT THAT XR,XL
24207: # CAN ONLY CONTAIN PROPER COLLECTABLE POINTERS.
24208: #
24209: # SOME OF THESE ROUTINES WILL TOLERATE GARBAGE POINTERS
24210: # IN XL,XR ON ENTRY. THIS IS ALWAYS DOCUMENTED AND IN
24211: # EACH CASE, THE ROUTINE CLEARS THESE GARBAGE VALUES BEFORE
24212: # EXITING AFTER COMPLETING ITS TASK.
24213: #
24214: # THE ROUTINES HAVE NAMES CONSISTING OF FIVE LETTERS
24215: # AND ARE ASSEMBLED IN ALPHABETICAL ORDER.
24216: #page
24217: # ARREF -- ARRAY REFERENCE
24218: #
24219: # (XL) MAY BE NON-COLLECTABLE
24220: # (XR) NUMBER OF SUBSCRIPTS
24221: # (WB) SET ZERO/NONZERO FOR VALUE/NAME
24222: # THE VALUE IN WB MUST BE COLLECTABLE
24223: # STACK SUBSCRIPTS AND ARRAY OPERAND
24224: # BRN ARREF JUMP TO CALL FUNCTION
24225: #
24226: # ARREF CONTINUES BY EXECUTING THE NEXT CODE WORD WITH
24227: # THE RESULT NAME OR VALUE PLACED ON TOP OF THE STACK.
24228: # TO DEAL WITH THE PROBLEM OF ACCESSING SUBSCRIPTS IN THE
24229: # ORDER OF STACKING, XL IS USED AS A SUBSCRIPT POINTER
24230: # WORKING BELOW THE STACK POINTER.
24231: #
24232: arref: #rtn
24233: movl r9,r6 # copy number of subscripts
24234: movl sp,r10 # point to stack front
24235: moval 0[r9],r9 # convert to byte offset
24236: addl2 r9,r10 # point to array operand on stack
24237: addl2 $4,r10 # final value for stack popping
24238: movl r10,arfxs # keep for later
24239: movl -(r10),r9 # load array operand pointer
24240: movl r9,r$arf # keep array pointer
24241: movl r10,r9 # save pointer to subscripts
24242: movl r$arf,r10 # point xl to possible vcblk or tbblk
24243: movl (r10),r8 # load first word
24244: cmpl r8,$b$art # jump if arblk
24245: beqlu arf01
24246: cmpl r8,$b$vct # jump if vcblk
24247: bnequ 0f
24248: jmp arf07
24249: 0:
24250: cmpl r8,$b$tbt # jump if tbblk
24251: bnequ 0f
24252: jmp arf10
24253: 0:
24254: jmp er_235 # subscripted operand is not table or array
24255: #
24256: # HERE FOR ARRAY (ARBLK)
24257: #
24258: arf01: cmpl r6,4*arndm(r10) # jump if wrong number of dims
24259: beqlu 0f
24260: jmp arf09
24261: 0:
24262: movl intv0,r5 # get initial subscript of zero
24263: movl r9,r10 # point before subscripts
24264: clrl r6 # initial offset to bounds
24265: jmp arf03 # jump into loop
24266: #
24267: # LOOP TO COMPUTE SUBSCRIPTS BY MULTIPLICATIONS
24268: #
24269: arf02: mull2 4*ardm2(r9),r5 # multiply total by next dimension
24270: #
24271: # MERGE HERE FIRST TIME
24272: #
24273: arf03: movl -(r10),r9 # load next subscript
24274: movl r5,arfsi # save current subscript
24275: movl 4*icval(r9),r5 # load integer value in case
24276: cmpl (r9),$b$icl # jump if it was an integer
24277: beqlu arf04
24278: #page
24279: #
24280: # ARREF (CONTINUED)
24281: #
24282: #
24283: jsb gtint # convert to integer
24284: .long arf12 # jump if not integer
24285: movl 4*icval(r9),r5 # if ok, load integer value
24286: #
24287: # HERE WITH INTEGER SUBSCRIPT IN (IA)
24288: #
24289: arf04: movl r$arf,r9 # point to array
24290: addl2 r6,r9 # offset to next bounds
24291: subl2 4*arlbd(r9),r5 # subtract low bound to compare
24292: bvc 0f
24293: jmp arf13
24294: 0:
24295: tstl r5 # out of range fail if too small
24296: bgeq 0f
24297: jmp arf13
24298: 0:
24299: subl2 4*ardim(r9),r5 # subtract dimension
24300: blss 0f # out of range fail if too large
24301: jmp arf13
24302: 0:
24303: addl2 4*ardim(r9),r5 # else restore subscript offset
24304: addl2 arfsi,r5 # add to current total
24305: addl2 $4*ardms,r6 # point to next bounds
24306: cmpl r10,sp # loop back if more to go
24307: bnequ arf02
24308: #
24309: # HERE WITH INTEGER SUBSCRIPT COMPUTED
24310: #
24311: movl r5,r6 # get as one word integer
24312: moval 0[r6],r6 # convert to offset
24313: movl r$arf,r10 # point to arblk
24314: addl2 4*arofs(r10),r6 # add offset past bounds
24315: addl2 $4,r6 # adjust for arpro field
24316: tstl r7 # exit with name if name call
24317: bnequ arf08
24318: #
24319: # MERGE HERE TO GET VALUE FOR VALUE CALL
24320: #
24321: arf05: jsb acess # get value
24322: .long arf13 # fail if acess fails
24323: #
24324: # RETURN VALUE
24325: #
24326: arf06: movl arfxs,sp # pop stack entries
24327: clrl r$arf # finished with array pointer
24328: jmp exixr # exit with value in xr
24329: #page
24330: #
24331: # ARREF (CONTINUED)
24332: #
24333: # HERE FOR VECTOR
24334: #
24335: arf07: cmpl r6,$num01 # error if more than 1 subscript
24336: beqlu 0f
24337: jmp arf09
24338: 0:
24339: movl (sp),r9 # else load subscript
24340: jsb gtint # convert to integer
24341: .long arf12 # error if not integer
24342: movl 4*icval(r9),r5 # else load integer value
24343: subl2 intv1,r5 # subtract for ones offset
24344: movl r5,r6 # get subscript as one word
24345: bgeq 0f
24346: jmp arf13
24347: 0:
24348: addl2 $vcvls,r6 # add offset for standard fields
24349: moval 0[r6],r6 # convert offset to bytes
24350: cmpl r6,4*vclen(r10) # fail if out of range subscript
24351: blssu 0f
24352: jmp arf13
24353: 0:
24354: tstl r7 # back to get value if value call
24355: beqlu arf05
24356: #
24357: # RETURN NAME
24358: #
24359: arf08: movl arfxs,sp # pop stack entries
24360: clrl r$arf # finished with array pointer
24361: jmp exnam # else exit with name
24362: #
24363: # HERE IF SUBSCRIPT COUNT IS WRONG
24364: #
24365: arf09: jmp er_236 # array referenced with wrong number of subscripts
24366: #
24367: # TABLE
24368: #
24369: arf10: cmpl r6,$num01 # error if more than 1 subscript
24370: bnequ arf11
24371: movl (sp),r9 # else load subscript
24372: jsb tfind # call table search routine
24373: .long arf13 # fail if failed
24374: tstl r7 # exit with name if name call
24375: bnequ arf08
24376: jmp arf06 # else exit with value
24377: #
24378: # HERE FOR BAD TABLE REFERENCE
24379: #
24380: arf11: jmp er_237 # table referenced with more than one subscript
24381: #
24382: # HERE FOR BAD SUBSCRIPT
24383: #
24384: arf12: jmp er_238 # array subscript is not integer
24385: #
24386: # HERE TO SIGNAL FAILURE
24387: #
24388: arf13: clrl r$arf # finished with array pointer
24389: jmp exfal # fail
24390: #page
24391: #
24392: # CFUNC -- CALL A FUNCTION
24393: #
24394: # CFUNC IS USED TO CALL A SNOBOL LEVEL FUNCTION. IT IS
24395: # USED BY THE APPLY FUNCTION (S$APP), THE FUNCTION
24396: # TRACE ROUTINE (TRXEQ) AND THE MAIN FUNCTION CALL ENTRY
24397: # (O$FNC, O$FNS). IN THE LATTER CASES, CFUNC IS USED ONLY
24398: # IF THE NUMBER OF ARGUMENTS IS INCORRECT.
24399: #
24400: # (XL) POINTER TO FUNCTION BLOCK
24401: # (WA) ACTUAL NUMBER OF ARGUMENTS
24402: # (XS) POINTS TO STACKED ARGUMENTS
24403: # BRN CFUNC JUMP TO CALL FUNCTION
24404: #
24405: # CFUNC CONTINUES BY EXECUTING THE FUNCTION
24406: #
24407: cfunc: #rtn
24408: cmpl r6,4*fargs(r10) # jump if too few arguments
24409: blssu cfnc1
24410: cmpl r6,4*fargs(r10) # jump if correct number of args
24411: beqlu cfnc3
24412: #
24413: # HERE IF TOO MANY ARGUMENTS SUPPLIED, POP THEM OFF
24414: #
24415: movl r6,r7 # copy actual number
24416: subl2 4*fargs(r10),r7 # get number of extra args
24417: moval 0[r7],r7 # convert to bytes
24418: addl2 r7,sp # pop off unwanted arguments
24419: jmp cfnc3 # jump to go off to function
24420: #
24421: # HERE IF TOO FEW ARGUMENTS
24422: #
24423: cfnc1: movl 4*fargs(r10),r7 # load required number of arguments
24424: cmpl r7,$nini9 # jump if case of var num of args
24425: beqlu cfnc3
24426: subl2 r6,r7 # calculate number missing
24427: # set counter to control loop
24428: #
24429: # LOOP TO SUPPLY EXTRA NULL ARGUMENTS
24430: #
24431: cfnc2: movl $nulls,-(sp) # stack a null argument
24432: sobgtr r7,cfnc2 # loop till proper number stacked
24433: #
24434: # MERGE HERE TO JUMP TO FUNCTION
24435: #
24436: cfnc3: movl (r10),r11 # jump through fcode field
24437: jmp (r11)
24438: #page
24439: #
24440: # EXFAL -- EXIT SIGNALLING SNOBOL FAILURE
24441: #
24442: # (XL,XR) MAY BE NON-COLLECTABLE
24443: # BRN EXFAL JUMP TO FAIL
24444: #
24445: # EXFAL CONTINUES BY EXECUTING THE APPROPRIATE FAIL GOTO
24446: #
24447: exfal: #rtn
24448: movl flptr,sp # pop stack
24449: movl (sp),r9 # load failure offset
24450: addl2 r$cod,r9 # point to failure code location
24451: movl r9,r3 # set code pointer
24452: jmp exits # do next code word
24453: #page
24454: #
24455: # EXINT -- EXIT WITH INTEGER RESULT
24456: #
24457: # (XL,XR) MAY BE NONCOLLECTABLE
24458: # (IA) INTEGER VALUE
24459: # BRN EXINT JUMP TO EXIT WITH INTEGER
24460: #
24461: # EXINT CONTINUES BY EXECUTING THE NEXT CODE WORD
24462: # WHICH IT DOES BY FALLING THROUGH TO EXIXR
24463: #
24464: exint: #rtn
24465: jsb icbld # build icblk
24466: #page
24467: # EXIXR -- EXIT WITH RESULT IN (XR)
24468: #
24469: # (XR) RESULT
24470: # (XL) MAY BE NON-COLLECTABLE
24471: # BRN EXIXR JUMP TO EXIT WITH RESULT IN (XR)
24472: #
24473: # EXIXR CONTINUES BY EXECUTING THE NEXT CODE WORD
24474: # WHICH IT DOES BY FALLING THROUGH TO EXITS.
24475: exixr: #rtn
24476: #
24477: movl r9,-(sp) # stack result
24478: #
24479: #
24480: # EXITS -- EXIT WITH RESULT IF ANY STACKED
24481: #
24482: # (XR,XL) MAY BE NON-COLLECTABLE
24483: #
24484: # BRN EXITS ENTER EXITS ROUTINE
24485: #
24486: exits: #rtn
24487: movl (r3)+,r9 # load next code word
24488: movl (r9),r10 # load entry address
24489: movl r10,r11 # jump to execute next code word
24490: jmp (r11)
24491: #page
24492: #
24493: # EXNAM -- EXIT WITH NAME IN (XL,WA)
24494: #
24495: # (XL) NAME BASE
24496: # (WA) NAME OFFSET
24497: # (XR) MAY BE NON-COLLECTABLE
24498: # BRN EXNAM JUMP TO EXIT WITH NAME IN (XL,WA)
24499: #
24500: # EXNAM CONTINUES BY EXECUTING THE NEXT CODE WORD
24501: #
24502: exnam: #rtn
24503: movl r10,-(sp) # stack name base
24504: movl r6,-(sp) # stack name offset
24505: jmp exits # do next code word
24506: #page
24507: #
24508: # EXNUL -- EXIT WITH NULL RESULT
24509: #
24510: # (XL,XR) MAY BE NON-COLLECTABLE
24511: # BRN EXNUL JUMP TO EXIT WITH NULL VALUE
24512: #
24513: # EXNUL CONTINUES BY EXECUTING THE NEXT CODE WORD
24514: #
24515: exnul: #rtn
24516: movl $nulls,-(sp) # stack null value
24517: jmp exits # do next code word
24518: #page
24519: #
24520: # EXREA -- EXIT WITH REAL RESULT
24521: #
24522: # (XL,XR) MAY BE NON-COLLECTABLE
24523: # (RA) REAL VALUE
24524: # BRN EXREA JUMP TO EXIT WITH REAL VALUE
24525: #
24526: # EXREA CONTINUES BY EXECUTING THE NEXT CODE WORD
24527: #
24528: exrea: #rtn
24529: jsb rcbld # build rcblk
24530: jmp exixr # jump to exit with result in xr
24531: #page
24532: #
24533: # EXSID -- EXIT SETTING ID FIELD
24534: #
24535: # EXSID IS USED TO EXIT AFTER BUILDING ANY OF THE FOLLOWING
24536: # BLOCKS (ARBLK, TBBLK, PDBLK, VCBLK). IT SETS THE IDVAL.
24537: #
24538: # (XR) PTR TO BLOCK WITH IDVAL FIELD
24539: # (XL) MAY BE NON-COLLECTABLE
24540: # BRN EXSID JUMP TO EXIT AFTER SETTING ID FIELD
24541: #
24542: # EXSID CONTINUES BY EXECUTING THE NEXT CODE WORD
24543: #
24544: exsid: #rtn
24545: movl curid,r6 # load current id value
24546: cmpl r6,$cfp$m # jump if no overflow
24547: bnequ exsi1
24548: clrl r6 # else reset for wraparound
24549: #
24550: # HERE WITH OLD IDVAL IN WA
24551: #
24552: exsi1: incl r6 # bump id value
24553: movl r6,curid # store for next time
24554: movl r6,4*idval(r9) # store id value
24555: jmp exixr # exit with result in (xr)
24556: #page
24557: #
24558: # EXVNM -- EXIT WITH NAME OF VARIABLE
24559: #
24560: # EXVNM EXITS AFTER STACKING A VALUE WHICH IS A NMBLK
24561: # REFERENCING THE NAME OF A GIVEN NATURAL VARIABLE.
24562: #
24563: # (XR) VRBLK POINTER
24564: # (XL) MAY BE NON-COLLECTABLE
24565: # BRN EXVNM EXIT WITH VRBLK POINTER IN XR
24566: #
24567: exvnm: #rtn
24568: movl r9,r10 # copy name base pointer
24569: movl $4*nmsi$,r6 # set size of nmblk
24570: jsb alloc # allocate nmblk
24571: movl $b$nml,(r9) # store type word
24572: movl r10,4*nmbas(r9) # store name base
24573: movl $4*vrval,4*nmofs(r9) # store name offset
24574: jmp exixr # exit with result in xr
24575: #page
24576: #
24577: # FLPOP -- FAIL AND POP IN PATTERN MATCHING
24578: #
24579: # FLPOP POPS THE NODE AND CURSOR ON THE STACK AND THEN
24580: # DROPS THROUGH INTO FAILP TO CAUSE PATTERN FAILURE
24581: #
24582: # (XL,XR) MAY BE NON-COLLECTABLE
24583: # BRN FLPOP JUMP TO FAIL AND POP STACK
24584: #
24585: flpop: #rtn
24586: addl2 $4*num02,sp # pop two entries off stack
24587: #page
24588: #
24589: # FAILP -- FAILURE IN MATCHING PATTERN NODE
24590: #
24591: # FAILP IS USED AFTER FAILING TO MATCH A PATTERN NODE.
24592: # SEE PATTERN MATCH ROUTINES FOR DETAILS OF USE.
24593: #
24594: # (XL,XR) MAY BE NON-COLLECTABLE
24595: # BRN FAILP SIGNAL FAILURE TO MATCH
24596: #
24597: # FAILP CONTINUES BY MATCHING AN ALTERNATIVE FROM THE STACK
24598: #
24599: failp: #rtn
24600: movl (sp)+,r9 # load alternative node pointer
24601: movl (sp)+,r7 # restore old cursor
24602: movl (r9),r10 # load pcode entry pointer
24603: movl r10,r11 # jump to execute code for node
24604: jmp (r11)
24605: #page
24606: #
24607: # INDIR -- COMPUTE INDIRECT REFERENCE
24608: #
24609: # (WB) NONZERO/ZERO FOR BY NAME/VALUE
24610: # BRN INDIR JUMP TO GET INDIRECT REF ON STACK
24611: #
24612: # INDIR CONTINUES BY EXECUTING THE NEXT CODE WORD
24613: #
24614: indir: #rtn
24615: movl (sp)+,r9 # load argument
24616: cmpl (r9),$b$nml # jump if a name
24617: beqlu indr2
24618: jsb gtnvr # else convert to variable
24619: .long er_239 # indirection operand is not name
24620: tstl r7 # skip if by value
24621: beqlu indr1
24622: movl r9,-(sp) # else stack vrblk ptr
24623: movl $4*vrval,-(sp) # stack name offset
24624: jmp exits # exit with result on stack
24625: #
24626: # HERE TO GET VALUE OF NATURAL VARIABLE
24627: #
24628: indr1: movl (r9),r11 # jump through vrget field of vrblk
24629: jmp (r11)
24630: #
24631: # HERE IF OPERAND IS A NAME
24632: #
24633: indr2: movl 4*nmbas(r9),r10 # load name base
24634: movl 4*nmofs(r9),r6 # load name offset
24635: tstl r7 # exit if called by name
24636: beqlu 0f
24637: jmp exnam
24638: 0:
24639: jsb acess # else get value first
24640: .long exfal # fail if access fails
24641: jmp exixr # else return with value in xr
24642: #page
24643: #
24644: # MATCH -- INITIATE PATTERN MATCH
24645: #
24646: # (WB) MATCH TYPE CODE
24647: # BRN MATCH JUMP TO INITIATE PATTERN MATCH
24648: #
24649: # MATCH CONTINUES BY EXECUTING THE PATTERN MATCH. SEE
24650: # PATTERN MATCH ROUTINES (P$XXX) FOR FULL DETAILS.
24651: #
24652: match: #rtn
24653: movl (sp)+,r9 # load pattern operand
24654: jsb gtpat # convert to pattern
24655: .long er_240 # pattern match right operand is not pattern
24656: movl r9,r10 # if ok, save pattern pointer
24657: tstl r7 # jump if not match by name
24658: bnequ mtch1
24659: movl (sp),r6 # else load name offset
24660: movl r10,-(sp) # save pattern pointer
24661: movl 4*2(sp),r10 # load name base
24662: jsb acess # access subject value
24663: .long exfal # fail if access fails
24664: movl (sp),r10 # restore pattern pointer
24665: movl r9,(sp) # stack subject string val for merge
24666: clrl r7 # restore type code
24667: #
24668: # MERGE HERE WITH SUBJECT VALUE ON STACK
24669: #
24670: mtch1: movl (sp),r9 # load subject value
24671: clrl r$pmb # assume not a buffer
24672: cmpl (r9),$b$bct # branch if not
24673: bnequ mtcha
24674: addl2 $4,sp # else pop value
24675: movl r9,r$pmb # save pointer
24676: movl 4*bclen(r9),r6 # get defined length
24677: movl 4*bcbuf(r9),r9 # point to bfblk
24678: jmp mtchb
24679: #
24680: # HERE IF NOT BUFFER TO CONVERT TO STRING
24681: #
24682: mtcha: jsb gtstg # not buffer - convert to string
24683: .long er_241 # pattern match left operand is not string
24684: #
24685: # MERGE WITH BUFFER OR STRING
24686: #
24687: mtchb: movl r9,r$pms # if ok, store subject string pointer
24688: movl r6,pmssl # and length
24689: movl r7,-(sp) # stack match type code
24690: clrl -(sp) # stack initial cursor (zero)
24691: clrl r7 # set initial cursor
24692: movl sp,pmhbs # set history stack base ptr
24693: clrl pmdfl # reset pattern assignment flag
24694: movl r10,r9 # set initial node pointer
24695: tstl kvanc # jump if anchored
24696: bnequ mtch2
24697: #
24698: # HERE FOR UNANCHORED
24699: #
24700: movl r9,-(sp) # stack initial node pointer
24701: movl $nduna,-(sp) # stack pointer to anchor move node
24702: movl (r9),r11 # start match of first node
24703: jmp (r11)
24704: #
24705: # HERE IN ANCHORED MODE
24706: #
24707: mtch2: clrl -(sp) # dummy cursor value
24708: movl $ndabo,-(sp) # stack pointer to abort node
24709: movl (r9),r11 # start match of first node
24710: jmp (r11)
24711: #page
24712: #
24713: # RETRN -- RETURN FROM FUNCTION
24714: #
24715: # (WA) STRING POINTER FOR RETURN TYPE
24716: # BRN RETRN JUMP TO RETURN FROM (SNOBOL) FUNC
24717: #
24718: # RETRN CONTINUES BY EXECUTING THE CODE AT THE RETURN POINT
24719: # THE STACK IS CLEANED OF ANY GARBAGE LEFT BY OTHER
24720: # ROUTINES WHICH MAY HAVE ALTERED FLPTR SINCE FUNCTION
24721: # ENTRY BY USING FLPRT, RESERVED FOR USE ONLY BY
24722: # FUNCTION CALL AND RETURN.
24723: #
24724: retrn: #rtn
24725: tstl kvfnc # jump if not level zero
24726: bnequ rtn01
24727: jmp er_242 # function return from level zero
24728: #
24729: # HERE IF NOT LEVEL ZERO RETURN
24730: #
24731: rtn01: movl flprt,sp # pop stack
24732: addl2 $4,sp # remove failure offset
24733: movl (sp)+,r9 # pop pfblk pointer
24734: movl (sp)+,flptr # pop failure pointer
24735: movl (sp)+,flprt # pop old flprt
24736: movl (sp)+,r7 # pop code pointer offset
24737: movl (sp)+,r8 # pop old code block pointer
24738: addl2 r8,r7 # make old code pointer absolute
24739: movl r7,r3 # restore old code pointer
24740: movl r8,r$cod # restore old code block pointer
24741: decl kvfnc # decrement function level
24742: movl kvtra,r7 # load trace
24743: addl2 kvftr,r7 # add ftrace
24744: bnequ 0f # jump if no tracing possible
24745: jmp rtn06
24746: 0:
24747: #
24748: # HERE IF THERE MAY BE A TRACE
24749: #
24750: movl r6,-(sp) # save function return type
24751: movl r9,-(sp) # save pfblk pointer
24752: movl r6,kvrtn # set rtntype for trace function
24753: movl r$fnc,r10 # load fnclevel trblk ptr (if any)
24754: jsb ktrex # execute possible fnclevel trace
24755: movl 4*pfvbl(r9),r10 # load vrblk ptr (sgd13)
24756: tstl kvtra # jump if trace is off
24757: beqlu rtn02
24758: movl 4*pfrtr(r9),r9 # else load return trace trblk ptr
24759: beqlu rtn02 # jump if not return traced
24760: decl kvtra # else decrement trace count
24761: tstl 4*trfnc(r9) # jump if print trace
24762: beqlu rtn03
24763: movl $4*vrval,r6 # else set name offset
24764: movl 4*1(sp),kvrtn # make sure rtntype is set right
24765: jsb trxeq # execute full trace
24766: #page
24767: #
24768: # RETRN (CONTINUED)
24769: #
24770: # HERE TO TEST FOR FTRACE
24771: #
24772: rtn02: tstl kvftr # jump if ftrace is off
24773: beqlu rtn05
24774: decl kvftr # else decrement ftrace
24775: #
24776: # HERE FOR PRINT TRACE OF FUNCTION RETURN
24777: #
24778: rtn03: jsb prtsn # print statement number
24779: movl 4*1(sp),r9 # load return type
24780: jsb prtst # print it
24781: movl $ch$bl,r6 # load blank
24782: jsb prtch # print it
24783: movl (sp),r10 # load pfblk ptr
24784: movl 4*pfvbl(r10),r10# load function vrblk ptr
24785: movl $4*vrval,r6 # set vrblk name offset
24786: cmpl r9,$scfrt # jump if not freturn case
24787: bnequ rtn04
24788: #
24789: # FOR FRETURN, JUST PRINT FUNCTION NAME
24790: #
24791: jsb prtnm # print name
24792: jsb prtnl # terminate print line
24793: jmp rtn05 # merge
24794: #
24795: # HERE FOR RETURN OR NRETURN, PRINT FUNCTION NAME = VALUE
24796: #
24797: rtn04: jsb prtnv # print name = value
24798: #
24799: # HERE AFTER COMPLETING TRACE
24800: #
24801: rtn05: movl (sp)+,r9 # pop pfblk pointer
24802: movl (sp)+,r6 # pop return type string
24803: #
24804: # MERGE HERE IF NO TRACE REQUIRED
24805: #
24806: rtn06: movl r6,kvrtn # set rtntype keyword
24807: movl 4*pfvbl(r9),r10 # load pointer to fn vrblk
24808: #page
24809: # RETRN (CONTINUED)
24810: #
24811: # GET VALUE OF FUNCTION
24812: #
24813: rtn07: movl r10,rtnbp # save block pointer
24814: movl 4*vrval(r10),r10# load value
24815: cmpl (r10),$b$trt # loop back if trapped
24816: beqlu rtn07
24817: movl r10,rtnfv # else save function result value
24818: movl (sp)+,rtnsv # save original function value
24819: movl (sp)+,r10 # pop saved pointer
24820: beqlu rtn7c # no action if none
24821: tstl kvpfl # jump if no profiling
24822: beqlu rtn7c
24823: jsb prflu # else profile last func stmt
24824: cmpl kvpfl,$num02 # branch on value of profile keywd
24825: beqlu rtn7a
24826: #
24827: # HERE IF &PROFILE = 1. START TIME MUST BE FRIGGED TO
24828: # APPEAR EARLIER THAN IT ACTUALLY IS, BY AMOUNT USED BEFORE
24829: # THE CALL.
24830: #
24831: movl pfstm,r5 # load current time
24832: subl2 4*icval(r10),r5 # frig by subtracting saved amount
24833: jmp rtn7b # and merge
24834: #
24835: # HERE IF &PROFILE = 2
24836: #
24837: rtn7a: movl 4*icval(r10),r5 # load saved time
24838: #
24839: # BOTH PROFILE TYPES MERGE HERE
24840: #
24841: rtn7b: movl r5,pfstm # store back correct start time
24842: #
24843: # MERGE HERE IF NO PROFILING
24844: #
24845: rtn7c: movl 4*fargs(r9),r7 # get number of args
24846: addl2 4*pfnlo(r9),r7 # add number of locals
24847: beqlu rtn10 # jump if no args/locals
24848: # else set loop counter
24849: addl2 4*pflen(r9),r9 # and point to end of pfblk
24850: #
24851: # LOOP TO RESTORE FUNCTIONS AND LOCALS
24852: #
24853: rtn08: movl -(r9),r10 # load next vrblk pointer
24854: #
24855: # LOOP TO FIND VALUE BLOCK
24856: #
24857: rtn09: movl r10,r6 # save block pointer
24858: movl 4*vrval(r10),r10# load pointer to next value
24859: cmpl (r10),$b$trt # loop back if trapped
24860: beqlu rtn09
24861: movl r6,r10 # else restore last block pointer
24862: movl (sp)+,4*vrval(r10) # restore old variable value
24863: sobgtr r7,rtn08 # loop till all processed
24864: #
24865: # NOW RESTORE FUNCTION VALUE AND EXIT
24866: #
24867: rtn10: movl rtnbp,r10 # restore ptr to last function block
24868: movl rtnsv,4*vrval(r10) # restore old function value
24869: movl rtnfv,r9 # reload function result
24870: movl r$cod,r10 # point to new code block
24871: movl kvstn,kvlst # set lastno from stno
24872: movl 4*cdstm(r10),kvstn # reset proper stno value
24873: movl kvrtn,r6 # load return type
24874: cmpl r6,$scrtn # exit with result in xr if return
24875: bnequ 0f
24876: jmp exixr
24877: 0:
24878: cmpl r6,$scfrt # fail if freturn
24879: bnequ 0f
24880: jmp exfal
24881: 0:
24882: #page
24883: #
24884: # RETRN (CONTINUED)
24885: #
24886: # HERE FOR NRETURN
24887: #
24888: cmpl (r9),$b$nml # jump if is a name
24889: beqlu rtn11
24890: jsb gtnvr # else try convert to variable name
24891: .long er_243 # function result in nreturn is not name
24892: movl r9,r10 # if ok, copy vrblk (name base) ptr
24893: movl $4*vrval,r6 # set name offset
24894: jmp rtn12 # and merge
24895: #
24896: # HERE IF RETURNED RESULT IS A NAME
24897: #
24898: rtn11: movl 4*nmbas(r9),r10 # load name base
24899: movl 4*nmofs(r9),r6 # load name offset
24900: #
24901: # MERGE HERE WITH RETURNED NAME IN (XL,WA)
24902: #
24903: rtn12: movl r10,r9 # preserve xl
24904: movl (r3)+,r7 # load next word
24905: movl r9,r10 # restore xl
24906: cmpl r7,$ofne$ # exit if called by name
24907: bnequ 0f
24908: jmp exnam
24909: 0:
24910: movl r7,-(sp) # else save code word
24911: jsb acess # get value
24912: .long exfal # fail if access fails
24913: movl r9,r10 # if ok, copy result
24914: movl (sp),r9 # reload next code word
24915: movl r10,(sp) # store result on stack
24916: movl (r9),r10 # load routine address
24917: movl r10,r11 # jump to execute next code word
24918: jmp (r11)
24919: #page
24920: #
24921: # STCOV -- SIGNAL STATEMENT COUNTER OVERFLOW
24922: #
24923: # BRN STCOV JUMP TO SIGNAL STATEMENT COUNT OFLO
24924: #
24925: # PERMIT UP TO 10 MORE STATEMENTS TO BE OBEYED SO THAT
24926: # SETEXIT TRAP CAN REGAIN CONTROL.
24927: # STCOV CONTINUES BY ISSUING THE ERROR MESSAGE
24928: #
24929: stcov: #rtn
24930: incl errft # fatal error
24931: movl intvt,r5 # get 10
24932: addl2 kvstl,r5 # add to former limit
24933: movl r5,kvstl # store as new stlimit
24934: movl intvt,r5 # get 10
24935: movl r5,kvstc # set as new count
24936: jmp er_244 # statement count exceeds value of stlimit keyword
24937: #page
24938: #
24939: # STMGO -- START EXECUTION OF NEW STATEMENT
24940: #
24941: # (XR) POINTER TO CDBLK FOR NEW STATEMENT
24942: # BRN STMGO JUMP TO EXECUTE NEW STATEMENT
24943: #
24944: # STMGO CONTINUES BY EXECUTING THE NEXT STATEMENT
24945: #
24946: stmgo: #rtn
24947: movl r9,r$cod # set new code block pointer
24948: tstl kvpfl # skip if no profiling
24949: beqlu stgo1
24950: jsb prflu # else profile the statement
24951: stgo1: movl kvstn,kvlst # set lastno
24952: movl 4*cdstm(r9),kvstn# set stno
24953: addl2 $4*cdcod,r9 # point to first code word
24954: movl r9,r3 # set code pointer
24955: movl kvstc,r5 # get stmt count
24956: bgeq 0f # omit counting if negative
24957: jmp exits
24958: 0:
24959: tstl r5 # fail if stlimit reached
24960: beql stcov
24961: subl2 intv1,r5 # decrement
24962: movl r5,kvstc # replace it
24963: tstl r$stc # exit if no stcount trace
24964: bnequ 0f
24965: jmp exits
24966: 0:
24967: #
24968: # HERE FOR STCOUNT TRACE
24969: #
24970: clrl r9 # clear garbage value in xr
24971: movl r$stc,r10 # load pointer to stcount trblk
24972: jsb ktrex # execute keyword trace
24973: jmp exits # and then exit for next code word
24974: #page
24975: #
24976: # STOPR -- TERMINATE RUN
24977: #
24978: # (XR) POINTS TO ENDING MESSAGE
24979: # BRN STOPR JUMP TO TERMINATE RUN
24980: #
24981: # TERMINATE RUN AND PRINT STATISTICS. ON ENTRY XR POINTS
24982: # TO ENDING MESSAGE OR IS ZERO IF MESSAGE PRINTED ALREADY.
24983: #
24984: stopr: #rtn
24985: tstl r9 # skip if sysax already called (reg04)
24986: beqlu stpra
24987: jsb sysax # call after execution proc
24988: stpra: addl2 rsmem,dname # use the reserve memory
24989: cmpl r9,$endms # skip if not normal end message
24990: bnequ stpr0
24991: tstl exsts # skip if exec stats suppressed
24992: beqlu 0f
24993: jmp stpr3
24994: 0:
24995: clrl erich # clear errors to int.ch. flag
24996: #
24997: # LOOK TO SEE IF AN ENDING MESSAGE IS SUPPLIED
24998: #
24999: stpr0: jsb prtpg # eject printer
25000: tstl r9 # skip if no message
25001: beqlu stpr1
25002: jsb prtst # print message
25003: #
25004: # MERGE HERE IF NO MESSAGE TO PRINT
25005: #
25006: stpr1: jsb prtis # print blank line
25007: movl kvstn,r5 # get statement number
25008: movl $stpm1,r9 # point to message /in statement xxx/
25009: jsb prtmx # print it
25010: jsb systm # get current time
25011: subl2 timsx,r5 # minus start time = elapsed exec tim
25012: movl r5,stpti # save for later
25013: movl $stpm3,r9 # point to msg /execution time msec /
25014: jsb prtmx # print it
25015: movl kvstl,r5 # get statement limit
25016: blss stpr2 # skip if negative
25017: subl2 kvstc,r5 # minus counter = count
25018: movl r5,stpsi # save
25019: movl $stpm2,r9 # point to message /stmts executed/
25020: jsb prtmx # print it
25021: movl stpti,r5 # reload elapsed time
25022: mull2 intth,r5 # *1000 (microsecs)
25023: bvs stpr2
25024: divl2 stpsi,r5 # divide by statement count
25025: bvs stpr2
25026: movl $stpm4,r9 # point to msg (mcsec per statement /
25027: jsb prtmx # print it
25028: #page
25029: #
25030: # STOPR (CONTINUED)
25031: #
25032: # MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT)
25033: #
25034: stpr2: movl gbcnt,r5 # load count of collections
25035: movl $stpm5,r9 # point to message /regenerations /
25036: jsb prtmx # print it
25037: jsb prtis # one more blank for luck
25038: #
25039: # CHECK IF DUMP REQUESTED
25040: #
25041: stpr3: jsb prflr # print profile if wanted
25042: #
25043: movl kvdmp,r9 # load dump keyword
25044: jsb dumpr # execute dump if requested
25045: movl r$fcb,r10 # get fcblk chain head
25046: movl kvabe,r6 # load abend value
25047: movl kvcod,r7 # load code value
25048: jsb sysej # exit to system
25049: #page
25050: #
25051: # SUCCP -- SIGNAL SUCCESSFUL MATCH OF A PATTERN NODE
25052: #
25053: # SEE PATTERN MATCH ROUTINES FOR DETAILS
25054: #
25055: # (XR) CURRENT NODE
25056: # (WB) CURRENT CURSOR
25057: # (XL) MAY BE NON-COLLECTABLE
25058: # BRN SUCCP SIGNAL SUCCESSFUL PATTERN MATCH
25059: #
25060: # SUCCP CONTINUES BY MATCHING THE SUCCESSOR NODE
25061: #
25062: succp: #rtn
25063: movl 4*pthen(r9),r9 # load successor node
25064: movl (r9),r10 # load node code entry address
25065: movl r10,r11 # jump to match successor node
25066: jmp (r11)
25067: #page
25068: #
25069: # SYSAB -- PRINT /ABNORMAL END/ AND TERMINATE
25070: #
25071: sysab: #rtn
25072: movl $endab,r9 # point to message
25073: movl $num01,kvabe # set abend flag
25074: jsb prtnl # skip to new line
25075: jmp stopr # jump to pack up
25076: #page
25077: #
25078: # SYSTU -- PRINT /TIME UP/ AND TERMINATE
25079: #
25080: systu: #rtn
25081: movl $endtu,r9 # point to message
25082: movl strtu,r6 # get chars /tu/
25083: movl r6,kvcod # put in kvcod
25084: movl timup,r6 # check state of timeup switch
25085: movl sp,timup # set switch
25086: tstl r6 # stop run if already set
25087: beqlu 0f
25088: jmp stopr
25089: 0:
25090: jmp er_245 # translation/execution time expired
25091: #title s p i t b o l -- stack overflow section
25092: #
25093: # CONTROL COMES HERE IF THE MAIN STACK OVERFLOWS
25094: #
25095: er_001: movzwl $1,r6
25096: jmp error
25097: er_002: movzwl $2,r6
25098: jmp error
25099: er_003: movzwl $3,r6
25100: jmp error
25101: er_004: movzwl $4,r6
25102: jmp error
25103: er_005: movzwl $5,r6
25104: jmp error
25105: er_006: movzwl $6,r6
25106: jmp error
25107: er_007: movzwl $7,r6
25108: jmp error
25109: er_008: movzwl $8,r6
25110: jmp error
25111: er_009: movzwl $9,r6
25112: jmp error
25113: er_010: movzwl $10,r6
25114: jmp error
25115: er_011: movzwl $11,r6
25116: jmp error
25117: er_012: movzwl $12,r6
25118: jmp error
25119: er_013: movzwl $13,r6
25120: jmp error
25121: er_014: movzwl $14,r6
25122: jmp error
25123: er_015: movzwl $15,r6
25124: jmp error
25125: er_016: movzwl $16,r6
25126: jmp error
25127: er_017: movzwl $17,r6
25128: jmp error
25129: er_018: movzwl $18,r6
25130: jmp error
25131: er_019: movzwl $19,r6
25132: jmp error
25133: er_020: movzwl $20,r6
25134: jmp error
25135: er_021: movzwl $21,r6
25136: jmp error
25137: er_022: movzwl $22,r6
25138: jmp error
25139: er_023: movzwl $23,r6
25140: jmp error
25141: er_024: movzwl $24,r6
25142: jmp error
25143: er_025: movzwl $25,r6
25144: jmp error
25145: er_026: movzwl $26,r6
25146: jmp error
25147: er_027: movzwl $27,r6
25148: jmp error
25149: er_028: movzwl $28,r6
25150: jmp error
25151: er_029: movzwl $29,r6
25152: jmp error
25153: er_030: movzwl $30,r6
25154: jmp error
25155: er_031: movzwl $31,r6
25156: jmp error
25157: er_032: movzwl $32,r6
25158: jmp error
25159: er_033: movzwl $33,r6
25160: jmp error
25161: er_034: movzwl $34,r6
25162: jmp error
25163: er_035: movzwl $35,r6
25164: jmp error
25165: er_036: movzwl $36,r6
25166: jmp error
25167: er_037: movzwl $37,r6
25168: jmp error
25169: er_038: movzwl $38,r6
25170: jmp error
25171: er_039: movzwl $39,r6
25172: jmp error
25173: er_040: movzwl $40,r6
25174: jmp error
25175: er_041: movzwl $41,r6
25176: jmp error
25177: er_042: movzwl $42,r6
25178: jmp error
25179: er_043: movzwl $43,r6
25180: jmp error
25181: er_044: movzwl $44,r6
25182: jmp error
25183: er_045: movzwl $45,r6
25184: jmp error
25185: er_046: movzwl $46,r6
25186: jmp error
25187: er_047: movzwl $47,r6
25188: jmp error
25189: er_048: movzwl $48,r6
25190: jmp error
25191: er_049: movzwl $49,r6
25192: jmp error
25193: er_050: movzwl $50,r6
25194: jmp error
25195: er_051: movzwl $51,r6
25196: jmp error
25197: er_052: movzwl $52,r6
25198: jmp error
25199: er_053: movzwl $53,r6
25200: jmp error
25201: er_054: movzwl $54,r6
25202: jmp error
25203: er_055: movzwl $55,r6
25204: jmp error
25205: er_056: movzwl $56,r6
25206: jmp error
25207: er_057: movzwl $57,r6
25208: jmp error
25209: er_058: movzwl $58,r6
25210: jmp error
25211: er_059: movzwl $59,r6
25212: jmp error
25213: er_060: movzwl $60,r6
25214: jmp error
25215: er_061: movzwl $61,r6
25216: jmp error
25217: er_062: movzwl $62,r6
25218: jmp error
25219: er_063: movzwl $63,r6
25220: jmp error
25221: er_064: movzwl $64,r6
25222: jmp error
25223: er_065: movzwl $65,r6
25224: jmp error
25225: er_066: movzwl $66,r6
25226: jmp error
25227: er_067: movzwl $67,r6
25228: jmp error
25229: er_068: movzwl $68,r6
25230: jmp error
25231: er_069: movzwl $69,r6
25232: jmp error
25233: er_070: movzwl $70,r6
25234: jmp error
25235: er_071: movzwl $71,r6
25236: jmp error
25237: er_072: movzwl $72,r6
25238: jmp error
25239: er_073: movzwl $73,r6
25240: jmp error
25241: er_074: movzwl $74,r6
25242: jmp error
25243: er_075: movzwl $75,r6
25244: jmp error
25245: er_076: movzwl $76,r6
25246: jmp error
25247: er_077: movzwl $77,r6
25248: jmp error
25249: er_078: movzwl $78,r6
25250: jmp error
25251: er_079: movzwl $79,r6
25252: jmp error
25253: er_080: movzwl $80,r6
25254: jmp error
25255: er_081: movzwl $81,r6
25256: jmp error
25257: er_082: movzwl $82,r6
25258: jmp error
25259: er_083: movzwl $83,r6
25260: jmp error
25261: er_084: movzwl $84,r6
25262: jmp error
25263: er_085: movzwl $85,r6
25264: jmp error
25265: er_086: movzwl $86,r6
25266: jmp error
25267: er_087: movzwl $87,r6
25268: jmp error
25269: er_088: movzwl $88,r6
25270: jmp error
25271: er_089: movzwl $89,r6
25272: jmp error
25273: er_090: movzwl $90,r6
25274: jmp error
25275: er_091: movzwl $91,r6
25276: jmp error
25277: er_092: movzwl $92,r6
25278: jmp error
25279: er_093: movzwl $93,r6
25280: jmp error
25281: er_094: movzwl $94,r6
25282: jmp error
25283: er_095: movzwl $95,r6
25284: jmp error
25285: er_096: movzwl $96,r6
25286: jmp error
25287: er_097: movzwl $97,r6
25288: jmp error
25289: er_098: movzwl $98,r6
25290: jmp error
25291: er_099: movzwl $99,r6
25292: jmp error
25293: er_100: movzwl $100,r6
25294: jmp error
25295: er_101: movzwl $101,r6
25296: jmp error
25297: er_102: movzwl $102,r6
25298: jmp error
25299: er_103: movzwl $103,r6
25300: jmp error
25301: er_104: movzwl $104,r6
25302: jmp error
25303: er_105: movzwl $105,r6
25304: jmp error
25305: er_106: movzwl $106,r6
25306: jmp error
25307: er_107: movzwl $107,r6
25308: jmp error
25309: er_108: movzwl $108,r6
25310: jmp error
25311: er_109: movzwl $109,r6
25312: jmp error
25313: er_110: movzwl $110,r6
25314: jmp error
25315: er_111: movzwl $111,r6
25316: jmp error
25317: er_112: movzwl $112,r6
25318: jmp error
25319: er_113: movzwl $113,r6
25320: jmp error
25321: er_114: movzwl $114,r6
25322: jmp error
25323: er_115: movzwl $115,r6
25324: jmp error
25325: er_116: movzwl $116,r6
25326: jmp error
25327: er_117: movzwl $117,r6
25328: jmp error
25329: er_118: movzwl $118,r6
25330: jmp error
25331: er_119: movzwl $119,r6
25332: jmp error
25333: er_120: movzwl $120,r6
25334: jmp error
25335: er_121: movzwl $121,r6
25336: jmp error
25337: er_122: movzwl $122,r6
25338: jmp error
25339: er_123: movzwl $123,r6
25340: jmp error
25341: er_124: movzwl $124,r6
25342: jmp error
25343: er_125: movzwl $125,r6
25344: jmp error
25345: er_126: movzwl $126,r6
25346: jmp error
25347: er_127: movzwl $127,r6
25348: jmp error
25349: er_128: movzwl $128,r6
25350: jmp error
25351: er_129: movzwl $129,r6
25352: jmp error
25353: er_130: movzwl $130,r6
25354: jmp error
25355: er_131: movzwl $131,r6
25356: jmp error
25357: er_132: movzwl $132,r6
25358: jmp error
25359: er_133: movzwl $133,r6
25360: jmp error
25361: er_134: movzwl $134,r6
25362: jmp error
25363: er_135: movzwl $135,r6
25364: jmp error
25365: er_136: movzwl $136,r6
25366: jmp error
25367: er_137: movzwl $137,r6
25368: jmp error
25369: er_138: movzwl $138,r6
25370: jmp error
25371: er_139: movzwl $139,r6
25372: jmp error
25373: er_140: movzwl $140,r6
25374: jmp error
25375: er_141: movzwl $141,r6
25376: jmp error
25377: er_142: movzwl $142,r6
25378: jmp error
25379: er_143: movzwl $143,r6
25380: jmp error
25381: er_144: movzwl $144,r6
25382: jmp error
25383: er_145: movzwl $145,r6
25384: jmp error
25385: er_146: movzwl $146,r6
25386: jmp error
25387: er_147: movzwl $147,r6
25388: jmp error
25389: er_148: movzwl $148,r6
25390: jmp error
25391: er_149: movzwl $149,r6
25392: jmp error
25393: er_150: movzwl $150,r6
25394: jmp error
25395: er_151: movzwl $151,r6
25396: jmp error
25397: er_152: movzwl $152,r6
25398: jmp error
25399: er_153: movzwl $153,r6
25400: jmp error
25401: er_154: movzwl $154,r6
25402: jmp error
25403: er_155: movzwl $155,r6
25404: jmp error
25405: er_156: movzwl $156,r6
25406: jmp error
25407: er_157: movzwl $157,r6
25408: jmp error
25409: er_158: movzwl $158,r6
25410: jmp error
25411: er_159: movzwl $159,r6
25412: jmp error
25413: er_160: movzwl $160,r6
25414: jmp error
25415: er_161: movzwl $161,r6
25416: jmp error
25417: er_162: movzwl $162,r6
25418: jmp error
25419: er_163: movzwl $163,r6
25420: jmp error
25421: er_164: movzwl $164,r6
25422: jmp error
25423: er_165: movzwl $165,r6
25424: jmp error
25425: er_166: movzwl $166,r6
25426: jmp error
25427: er_167: movzwl $167,r6
25428: jmp error
25429: er_168: movzwl $168,r6
25430: jmp error
25431: er_169: movzwl $169,r6
25432: jmp error
25433: er_170: movzwl $170,r6
25434: jmp error
25435: er_171: movzwl $171,r6
25436: jmp error
25437: er_172: movzwl $172,r6
25438: jmp error
25439: er_173: movzwl $173,r6
25440: jmp error
25441: er_174: movzwl $174,r6
25442: jmp error
25443: er_175: movzwl $175,r6
25444: jmp error
25445: er_176: movzwl $176,r6
25446: jmp error
25447: er_177: movzwl $177,r6
25448: jmp error
25449: er_178: movzwl $178,r6
25450: jmp error
25451: er_179: movzwl $179,r6
25452: jmp error
25453: er_180: movzwl $180,r6
25454: jmp error
25455: er_181: movzwl $181,r6
25456: jmp error
25457: er_182: movzwl $182,r6
25458: jmp error
25459: er_183: movzwl $183,r6
25460: jmp error
25461: er_184: movzwl $184,r6
25462: jmp error
25463: er_185: movzwl $185,r6
25464: jmp error
25465: er_186: movzwl $186,r6
25466: jmp error
25467: er_187: movzwl $187,r6
25468: jmp error
25469: er_188: movzwl $188,r6
25470: jmp error
25471: er_189: movzwl $189,r6
25472: jmp error
25473: er_190: movzwl $190,r6
25474: jmp error
25475: er_191: movzwl $191,r6
25476: jmp error
25477: er_192: movzwl $192,r6
25478: jmp error
25479: er_193: movzwl $193,r6
25480: jmp error
25481: er_194: movzwl $194,r6
25482: jmp error
25483: er_195: movzwl $195,r6
25484: jmp error
25485: er_196: movzwl $196,r6
25486: jmp error
25487: er_197: movzwl $197,r6
25488: jmp error
25489: er_198: movzwl $198,r6
25490: jmp error
25491: er_199: movzwl $199,r6
25492: jmp error
25493: er_200: movzwl $200,r6
25494: jmp error
25495: er_201: movzwl $201,r6
25496: jmp error
25497: er_202: movzwl $202,r6
25498: jmp error
25499: er_203: movzwl $203,r6
25500: jmp error
25501: er_204: movzwl $204,r6
25502: jmp error
25503: er_205: movzwl $205,r6
25504: jmp error
25505: er_206: movzwl $206,r6
25506: jmp error
25507: er_207: movzwl $207,r6
25508: jmp error
25509: er_208: movzwl $208,r6
25510: jmp error
25511: er_209: movzwl $209,r6
25512: jmp error
25513: er_210: movzwl $210,r6
25514: jmp error
25515: er_211: movzwl $211,r6
25516: jmp error
25517: er_212: movzwl $212,r6
25518: jmp error
25519: er_213: movzwl $213,r6
25520: jmp error
25521: er_214: movzwl $214,r6
25522: jmp error
25523: er_215: movzwl $215,r6
25524: jmp error
25525: er_216: movzwl $216,r6
25526: jmp error
25527: er_217: movzwl $217,r6
25528: jmp error
25529: er_218: movzwl $218,r6
25530: jmp error
25531: er_219: movzwl $219,r6
25532: jmp error
25533: er_220: movzwl $220,r6
25534: jmp error
25535: er_221: movzwl $221,r6
25536: jmp error
25537: er_222: movzwl $222,r6
25538: jmp error
25539: er_223: movzwl $223,r6
25540: jmp error
25541: er_224: movzwl $224,r6
25542: jmp error
25543: er_225: movzwl $225,r6
25544: jmp error
25545: er_226: movzwl $226,r6
25546: jmp error
25547: er_227: movzwl $227,r6
25548: jmp error
25549: er_228: movzwl $228,r6
25550: jmp error
25551: er_229: movzwl $229,r6
25552: jmp error
25553: er_230: movzwl $230,r6
25554: jmp error
25555: er_231: movzwl $231,r6
25556: jmp error
25557: er_232: movzwl $232,r6
25558: jmp error
25559: er_233: movzwl $233,r6
25560: jmp error
25561: er_234: movzwl $234,r6
25562: jmp error
25563: er_235: movzwl $235,r6
25564: jmp error
25565: er_236: movzwl $236,r6
25566: jmp error
25567: er_237: movzwl $237,r6
25568: jmp error
25569: er_238: movzwl $238,r6
25570: jmp error
25571: er_239: movzwl $239,r6
25572: jmp error
25573: er_240: movzwl $240,r6
25574: jmp error
25575: er_241: movzwl $241,r6
25576: jmp error
25577: er_242: movzwl $242,r6
25578: jmp error
25579: er_243: movzwl $243,r6
25580: jmp error
25581: er_244: movzwl $244,r6
25582: jmp error
25583: er_245: movzwl $245,r6
25584: jmp error
25585: er_246: movzwl $246,r6
25586: jmp error
25587: er_247: movzwl $247,r6
25588: jmp error
25589: er_248: movzwl $248,r6
25590: jmp error
25591: er_249: movzwl $249,r6
25592: jmp error
25593: er_250: movzwl $250,r6
25594: jmp error
25595: er_251: movzwl $251,r6
25596: jmp error
25597: er_252: movzwl $252,r6
25598: jmp error
25599: er_253: movzwl $253,r6
25600: jmp error
25601: er_254: movzwl $254,r6
25602: jmp error
25603: er_255: movzwl $255,r6
25604: jmp error
25605: er_256: movzwl $256,r6
25606: jmp error
25607: er_257: movzwl $257,r6
25608: jmp error
25609: er_258: movzwl $258,r6
25610: jmp error
25611: er_259: movzwl $259,r6
25612: jmp error
25613: er_260: movzwl $260,r6
25614: jmp error
25615: er_261: movzwl $261,r6
25616: jmp error
25617: er_262: movzwl $262,r6
25618: jmp error
25619: er_263: movzwl $263,r6
25620: jmp error
25621: er_264: movzwl $264,r6
25622: jmp error
25623: er_265: movzwl $265,r6
25624: jmp error
25625: er_266: movzwl $266,r6
25626: jmp error
25627: er_267: movzwl $267,r6
25628: jmp error
25629: er_268: movzwl $268,r6
25630: jmp error
25631: er_269: movzwl $269,r6
25632: jmp error
25633: er_270: movzwl $270,r6
25634: jmp error
25635: er_271: movzwl $271,r6
25636: jmp error
25637: er_272: movzwl $272,r6
25638: jmp error
25639: er_273: movzwl $273,r6
25640: jmp error
25641: er_274: movzwl $274,r6
25642: jmp error
25643: er_275: movzwl $275,r6
25644: jmp error
25645: er_276: movzwl $276,r6
25646: jmp error
25647: er_277: movzwl $277,r6
25648: jmp error
25649: er_278: movzwl $278,r6
25650: jmp error
25651: er_279: movzwl $279,r6
25652: jmp error
25653: er_280: movzwl $280,r6
25654: jmp error
25655: er_281: movzwl $281,r6
25656: jmp error
25657: er_282: movzwl $282,r6
25658: jmp error
25659: er_283: movzwl $283,r6
25660: jmp error
25661: er_284: movzwl $284,r6
25662: jmp error
25663: er_285: movzwl $285,r6
25664: jmp error
25665: er_286: movzwl $286,r6
25666: jmp error
25667: er_287: movzwl $287,r6
25668: jmp error
25669: er_288: movzwl $288,r6
25670: jmp error
25671: er_289: movzwl $289,r6
25672: jmp error
25673: er_290: movzwl $290,r6
25674: jmp error
25675: er_291: movzwl $291,r6
25676: jmp error
25677: er_292: movzwl $292,r6
25678: jmp error
25679: er_293: movzwl $293,r6
25680: jmp error
25681: er_294: movzwl $294,r6
25682: jmp error
25683: er_295: movzwl $295,r6
25684: jmp error
25685: er_296: movzwl $296,r6
25686: jmp error
25687: er_297: movzwl $297,r6
25688: jmp error
25689: .globl sec05
25690: sec05:
25691: #sec # start of stack overflow section
25692: #
25693: incl errft # fatal error
25694: movl flptr,sp # pop stack to avoid more fails
25695: tstl gbcfl # jump if garbage collecting
25696: bnequ stak1
25697: jmp er_246 # stack overflow
25698: #
25699: # NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION
25700: #
25701: stak1: movl $endso,r9 # point to message
25702: clrl kvdmp # memory is undumpable
25703: jmp stopr # give up
25704: #title s p i t b o l -- error section
25705: #
25706: # THIS SECTION OF CODE IS ENTERED WHENEVER A PROCEDURE
25707: # RETURN VIA AN ERR PARAMETER OR AN ERB OPCODE IS OBEYED.
25708: #
25709: # (WA) IS THE ERROR CODE
25710: #
25711: # THE GLOBAL VARIABLE STAGE INDICATES THE POINT AT WHICH
25712: # THE ERROR OCCURED AS FOLLOWS.
25713: #
25714: # STAGE=STGIC ERROR DURING INITIAL COMPILE
25715: #
25716: # STAGE=STGXC ERROR DURING COMPILE AT EXECUTE
25717: # TIME (CODE, CONVERT FUNCTION CALLS)
25718: #
25719: # STAGE=STGEV ERROR DURING COMPILATION OF
25720: # EXPRESSION AT EXECUTION TIME
25721: # (EVAL, CONVERT FUNCTION CALL).
25722: #
25723: # STAGE=STGXT ERROR AT EXECUTE TIME. COMPILER
25724: # NOT ACTIVE.
25725: #
25726: # STAGE=STGCE ERROR DURING INITIAL COMPILE AFTER
25727: # SCANNING OUT THE END LINE.
25728: #
25729: # STAGE=STGXE ERROR DURING COMPILE AT EXECUTE
25730: # TIME AFTER SCANNING END LINE.
25731: #
25732: # STAGE=STGEE ERROR DURING EXPRESSION EVALUATION
25733: #
25734: #sec # start of error section
25735: #
25736: error: cmpl r$cim,$cmlab # jump if error in scanning label
25737: bnequ 0f
25738: jmp cmple
25739: 0:
25740: movl r6,kvert # save error code
25741: clrl scnrs # reset rescan switch for scane
25742: clrl scngo # reset goto switch for scane
25743: movl stage,r9 # load current stage
25744: casel r9,$0,$stgno # jump to appropriate error circuit
25745: 5:
25746: .word err01-5b # initial compile
25747: .word err04-5b # execute time compile
25748: .word err04-5b # eval compiling expr.
25749: .word err05-5b # execute time
25750: .word err01-5b # compile - after end
25751: .word err04-5b # xeq compile-past end
25752: .word err04-5b # eval evaluating expr
25753: #esw # end switch on error type
25754: #page
25755: #
25756: # ERROR DURING INITIAL COMPILE
25757: #
25758: # THE ERROR MESSAGE IS PRINTED AS PART OF THE COMPILER
25759: # OUTPUT. THIS PRINTOUT INCLUDES THE OFFENDING LINE (IF NOT
25760: # PRINTED ALREADY) AND AN ERROR FLAG UNDER THE APPROPRIATE
25761: # COLUMN AS INDICATED BY SCNSE UNLESS SCNSE IS SET TO ZERO.
25762: #
25763: # AFTER PRINTING THE MESSAGE, THE GENERATED CODE IS
25764: # MODIFIED TO AN ERROR CALL AND CONTROL IS RETURNED TO
25765: # THE CMPIL PROCEDURE AFTER RESETTING THE STACK POINTER.
25766: #
25767: # IF THE ERROR OCCURS AFTER THE END LINE, CONTROL RETURNS
25768: # IN A SLIGHTLY DIFFERENT MANNER TO ENSURE PROPER CLEANUP.
25769: #
25770: err01: movl cmpxs,sp # reset stack pointer
25771: #ssl cmpss # restore s-r stack ptr for cmpil
25772: tstl errsp # jump if error suppress flag set
25773: beqlu 0f
25774: jmp err03
25775: 0:
25776: movl erich,erlst # set flag for listr
25777: jsb listr # list line
25778: jsb prtis # terminate listing
25779: clrl erlst # clear listr flag
25780: movl scnse,r6 # load scan element offset
25781: beqlu err02 # skip if not set
25782: movl r6,r7 # loop counter
25783: incl r6 # increase for ch$ex
25784: jsb alocs # string block for error flag
25785: movl r9,r6 # remember string ptr
25786: movab cfp$f(r9),r9 # ready for character storing
25787: movl r$cim,r10 # point to bad statement
25788: movab cfp$f(r10),r10 # ready to get chars
25789: #
25790: # LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS
25791: #
25792: erra1: movzbl (r10)+,r8 # get next char
25793: cmpl r8,$ch$ht # skip if tab
25794: beqlu erra2
25795: movl $ch$bl,r8 # get a blank
25796: #page
25797: #
25798: # MERGE TO STORE BLANK OR TAB IN ERROR LINE
25799: #
25800: erra2: movb r8,(r9)+ # store char
25801: sobgtr r7,erra1 # loop
25802: movl $ch$ex,r10 # exclamation mark
25803: movb r10,(r9) # store at end of error line
25804: #csc r9 # end of sch loop
25805: movl $stnpd,profs # allow for statement number
25806: movl r6,r9 # point to error line
25807: jsb prtst # print error line
25808: #
25809: # HERE AFTER PLACING ERROR FLAG AS REQUIRED
25810: #
25811: err02: jsb ermsg # generate flag and error message
25812: addl2 $num03,lstlc # bump page ctr for blank, error, blk
25813: clrl r9 # in case of fatal error
25814: cmpl errft,$num03 # pack up if several fatals
25815: blssu 0f
25816: jmp stopr
25817: 0:
25818: #
25819: # COUNT ERROR, INHIBIT EXECUTION IF REQUIRED
25820: #
25821: incl cmerc # bump error count
25822: addl2 cswer,noxeq # inhibit xeq if -noerrors
25823: cmpl stage,$stgic # special return if after end line
25824: beqlu 0f
25825: jmp cmp10
25826: 0:
25827: #page
25828: #
25829: # LOOP TO SCAN TO END OF STATEMENT
25830: #
25831: err03: movl r$cim,r9 # point to start of image
25832: movab cfp$f(r9),r9 # point to first char
25833: movzbl (r9),r9 # get first char
25834: cmpl r9,$ch$mn # jump if error in control card
25835: bnequ 0f
25836: jmp cmpce
25837: 0:
25838: clrl scnrs # clear rescan flag
25839: movl sp,errsp # set error suppress flag
25840: jsb scane # scan next element
25841: cmpl r10,$t$smc # loop back if not statement end
25842: beqlu 0f
25843: jmp err03
25844: 0:
25845: clrl errsp # clear error suppress flag
25846: #
25847: # GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL
25848: #
25849: movl $4*cdcod,cwcof # reset offset in ccblk
25850: movl $ocer$,r6 # load compile error call
25851: jsb cdwrd # generate it
25852: movl cwcof,4*cmsoc(sp)# set success fill in offset
25853: movl sp,4*cmffc(sp) # set failure fill in flag
25854: jsb cdwrd # generate succ. fill in word
25855: jmp cmpse # merge to generate error as cdfal
25856: #
25857: # ERROR DURING EXECUTE TIME COMPILE OR EXPRESSION EVALUATIO
25858: #
25859: # EXECUTE TIME COMPILATION IS INITIATED THROUGH GTCOD OR
25860: # GTEXP WHICH ARE CALLED BY COMPILE, CODE OR EVAL.
25861: # BEFORE CAUSING STATEMENT FAILURE THROUGH EXFAL IT IS
25862: # HELPFUL TO SET KEYWORD ERRTEXT AND FOR GENERALITY
25863: # THESE ERRORS MAY BE HANDLED BY THE SETEXIT MECHANISM.
25864: #
25865: err04: clrl r$ccb # forget garbage code block
25866: #ssl iniss # restore main prog s-r stack ptr
25867: jsb ertex # get fail message text
25868: subl2 $4,sp # ensure stack ok on loop start
25869: #
25870: # POP STACK UNTIL FIND FLPTR FOR MOST DEEPLY NESTED PROG.
25871: # DEFINED FUNCTION CALL OR CALL OF EVAL / CODE.
25872: #
25873: erra4: addl2 $4,sp # pop stack
25874: cmpl sp,flprt # jump if prog defined fn call found
25875: beqlu errc4
25876: cmpl sp,gtcef # loop if not eval or code call yet
25877: bnequ erra4
25878: movl $stgxt,stage # re-set stage for execute
25879: movl r$gtc,r$cod # recover code ptr
25880: movl sp,flptr # restore fail pointer
25881: clrl r$cim # forget possible image
25882: #
25883: # TEST ERRLIMIT
25884: #
25885: errb4: tstl kverl # jump if errlimit non-zero
25886: bnequ err07
25887: jmp exfal # fail
25888: #
25889: # RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING
25890: #
25891: errc4: movl flptr,sp # restore stack from flptr
25892: jmp errb4 # merge
25893: #page
25894: #
25895: # ERROR AT EXECUTE TIME.
25896: #
25897: # THE ACTION TAKEN ON AN ERROR IS AS FOLLOWS.
25898: #
25899: # IF ERRLIMIT KEYWORD IS ZERO, AN ABORT IS SIGNALLED,
25900: # SEE CODING FOR SYSTEM LABEL ABORT AT L$ABO.
25901: #
25902: # OTHERWISE, ERRLIMIT IS DECREMENTED AND AN ERRTYPE TRACE
25903: # GENERATED IF REQUIRED. CONTROL RETURNS EITHER VIA A JUMP
25904: # TO CONTINUE (TO TAKE THE FAILURE EXIT) OR A SPECIFIED
25905: # SETEXIT TRAP IS EXECUTED AND CONTROL PASSES TO THE TRAP.
25906: # IF 3 OR MORE FATAL ERRORS OCCUR AN ABORT IS SIGNALLED
25907: # REGARDLESS OF ERRLIMIT AND SETEXIT - LOOPING IS ALL TOO
25908: # PROBABLE OTHERWISE. FATAL ERRORS INCLUDE STACK OVERFLOW
25909: # AND EXCEEDING STLIMIT.
25910: #
25911: err05: #ssl iniss # restore main prog s-r stack ptr
25912: tstl dmvch # jump if in mid-dump
25913: bnequ err08
25914: #
25915: # MERGE HERE FROM ERR08
25916: #
25917: err06: tstl kverl # abort if errlimit is zero
25918: bnequ 0f
25919: jmp labo1
25920: 0:
25921: jsb ertex # get fail message text
25922: #
25923: # MERGE FROM ERR04
25924: #
25925: err07: cmpl errft,$num03 # abort if too many fatal errors
25926: blssu 0f
25927: jmp labo1
25928: 0:
25929: decl kverl # decrement errlimit
25930: movl r$ert,r10 # load errtype trace pointer
25931: jsb ktrex # generate errtype trace if required
25932: movl r$cod,r$cnt # set cdblk ptr for continuation
25933: movl flptr,r9 # set ptr to failure offset
25934: movl (r9),stxof # save failure offset for continue
25935: movl r$sxc,r9 # load setexit cdblk pointer
25936: bnequ 0f # continue if no setexit trap
25937: jmp lcnt1
25938: 0:
25939: clrl r$sxc # else reset trap
25940: movl $nulls,stxvr # reset setexit arg to null
25941: movl (r9),r10 # load ptr to code block routine
25942: movl r10,r11 # execute first trap statement
25943: jmp (r11)
25944: #
25945: # INTERRUPTED PARTLY THROUGH A DUMP WHILST STORE IS IN A
25946: # MESS SO DO A TIDY UP OPERATION. SEE DUMPR FOR DETAILS.
25947: #
25948: err08: movl dmvch,r9 # chain head for affected vrblks
25949: beqlu err06 # done if zero
25950: movl (r9),dmvch # set next link as chain head
25951: jsb setvr # restore vrget field
25952: jmp err08 # loop through chain
25953: #title s p i t b o l -- here endeth the code
25954: #
25955: # END OF ASSEMBLY
25956: #
25957: #end # end macro-spitbol assembly
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.