.TITLE Snobol4 .PAGE .SBTTL 'Table of Contents' ;00000001 ; 00000002 ; 00000003 ; E32 (DECEMBER 18, 1969) V3.7 ; UPDATED TO VERSION 3.10, NOV. 1, 1972 V3.10 ; 00000005 ; UPDATED TO VERSION 3.11, MAY 19, 1975. V3.11 ; 00000006 ; 1. Linkage and Equivalences . . . . . . . . . . . . . .252 00000007 ; Linkage . . . . . . . . . . . . . . . . . . . . .253 00000008 ; Machine Dependent Parameters. . . . . . . . . . .254 00000009 ; Constants . . . . . . . . . . . . . . . . . . . .258 00000010 ; Equivalences. . . . . . . . . . . . . . . . . . .288 00000011 ; Data Type Codes . . . . . . . . . . . . . . . . .317 00000012 ; 2. Program Initialization . . . . . . . . . . . . . . .330 00000013 ; 3. Compilation and Interpreter Invocation . . . . . . .376 00000014 ; 4. Support Procedures . . . . . . . . . . . . . . . . .426 00000015 ; AUGATL. . . . . . . . . . . . . . . . . . . . . .430 00000016 ; CODSKP. . . . . . . . . . . . . . . . . . . . . .454 00000017 ; DTREP . . . . . . . . . . . . . . . . . . . . . .473 00000018 ; FINDEX. . . . . . . . . . . . . . . . . . . . . .524 00000019 ; 5. Storage Allocation and Regeneration Procedures . . .548 00000020 ; BLOCK . . . . . . . . . . . . . . . . . . . . . .552 00000021 ; GENVAR. . . . . . . . . . . . . . . . . . . . . .577 00000022 ; GNVARI. . . . . . . . . . . . . . . . . . . . . .631 00000023 ; CONVAR. . . . . . . . . . . . . . . . . . . . . .641 00000024 ; GNVARS. . . . . . . . . . . . . . . . . . . . . .669 00000025 ; GC. . . . . . . . . . . . . . . . . . . . . . . .681 00000026 ; GCM . . . . . . . . . . . . . . . . . . . . . . .811 00000027 ; SPLIT . . . . . . . . . . . . . . . . . . . . . .841 00000028 ; 6. Compilation Procedures . . . . . . . . . . . . . . .857 00000029 ; BINOP . . . . . . . . . . . . . . . . . . . . . .861 00000030 ; CMPILE. . . . . . . . . . . . . . . . . . . . . .883 00000031 ; ELEMNT. . . . . . . . . . . . . . . . . . . . . 1136 00000032 ; EXPR. . . . . . . . . . . . . . . . . . . . . . 1265 00000033 ; FORWRD. . . . . . . . . . . . . . . . . . . . . 1342 00000034 ; NEWCRD. . . . . . . . . . . . . . . . . . . . . 1369 00000035 ; TREPUB. . . . . . . . . . . . . . . . . . . . . 1441 00000036 ; UNOP. . . . . . . . . . . . . . . . . . . . . . 1481 00000037 ; 7. Interpreter Executive and Control Procedures . . . 1495 00000038 ; BASE. . . . . . . . . . . . . . . . . . . . . . 1499 00000039 ; GOTG. . . . . . . . . . . . . . . . . . . . . . 1508 00000040 ; GOTL. . . . . . . . . . . . . . . . . . . . . . 1519 00000041 ; GOTO. . . . . . . . . . . . . . . . . . . . . . 1553 00000042 ; INIT. . . . . . . . . . . . . . . . . . . . . . 1562 00000043 ; INTERP. . . . . . . . . . . . . . . . . . . . . 1582 00000044 ; INVOKE. . . . . . . . . . . . . . . . . . . . . 1600 00000045 ; 8. Argument Evaluation Procedures . . . . . . . . . . 1610 00000046 ; ARGVAL. . . . . . . . . . . . . . . . . . . . . 1614 00000047 ; EXPVAL. . . . . . . . . . . . . . . . . . . . . 1633 00000048 ; EXPEVL. . . . . . . . . . . . . . . . . . . . . 1681 00000049 ; EVAL. . . . . . . . . . . . . . . . . . . . . . 1685 00000050 ; INTVAL. . . . . . . . . . . . . . . . . . . . . 1704 00000051 ; PATVAL. . . . . . . . . . . . . . . . . . . . . 1728 00000052 ; VARVAL. . . . . . . . . . . . . . . . . . . . . 1762 00000053 ; XYARGS. . . . . . . . . . . . . . . . . . . . . 1784 00000054 ; 9. Arithmetic Operations, Predicates and Functions. . 1812 00000055 ; ADD . . . . . . . . . . . . . . . . . . . . . . 1813 00000056 ; DIV . . . . . . . . . . . . . . . . . . . . . . 1817 00000057 ; EXP . . . . . . . . . . . . . . . . . . . . . . 1821 00000058 ; MPY . . . . . . . . . . . . . . . . . . . . . . 1825 00000059 ; SUB . . . . . . . . . . . . . . . . . . . . . . 1829 00000060 ; EQ. . . . . . . . . . . . . . . . . . . . . . . 1833 00000061 ; GE. . . . . . . . . . . . . . . . . . . . . . . 1837 00000062 ; GT. . . . . . . . . . . . . . . . . . . . . . . 1841 00000063 ; LE. . . . . . . . . . . . . . . . . . . . . . . 1845 00000064 ; LT. . . . . . . . . . . . . . . . . . . . . . . 1849 00000065 ; NE. . . . . . . . . . . . . . . . . . . . . . . 1853 00000066 ; REMDR . . . . . . . . . . . . . . . . . . . . . 1857 00000067 ; INTGER. . . . . . . . . . . . . . . . . . . . . 1966 00000068 ; MNS . . . . . . . . . . . . . . . . . . . . . . 1978 00000069 ; PLS . . . . . . . . . . . . . . . . . . . . . . 1997 00000070 ; 10. Pattern-Valued Functions and Operations . . . . . 2008 00000071 ; ANY . . . . . . . . . . . . . . . . . . . . . . 2009 00000072 ; BREAK . . . . . . . . . . . . . . . . . . . . . 2013 00000073 ; NOTANY. . . . . . . . . . . . . . . . . . . . . 2018 00000074 ; SPAN. . . . . . . . . . . . . . . . . . . . . . 2022 00000075 ; LEN . . . . . . . . . . . . . . . . . . . . . . 2036 00000076 ; POS . . . . . . . . . . . . . . . . . . . . . . 2040 00000077 ; RPOS. . . . . . . . . . . . . . . . . . . . . . 2044 00000078 ; RTAB. . . . . . . . . . . . . . . . . . . . . . 2048 00000079 ; TAB . . . . . . . . . . . . . . . . . . . . . . 2052 00000080 ; ARBNO . . . . . . . . . . . . . . . . . . . . . 2070 00000081 ; ATOP (Cursor Position). . . . . . . . . . . . . 2097 00000082 ; NAM (Value Assignment). . . . . . . . . . . . . 2111 00000083 ; OR. . . . . . . . . . . . . . . . . . . . . . . 2161 00000084 ; 11. Pattern Matching Procedures. . . . . . . . . . . . 2205 00000085 ; SCAN. . . . . . . . . . . . . . . . . . . . . . 2209 00000086 ; SJSR (Scan and Replace) . . . . . . . . . . . . 2255 00000087 ; SCNR (Basic Scanner). . . . . . . . . . . . . . 2404 00000088 ; ANYC. . . . . . . . . . . . . . . . . . . . . . 2509 00000089 ; BRKC. . . . . . . . . . . . . . . . . . . . . . 2543 00000090 ; NNYC. . . . . . . . . . . . . . . . . . . . . . 2557 00000091 ; SPNC. . . . . . . . . . . . . . . . . . . . . . 2571 00000092 ; LNTH. . . . . . . . . . . . . . . . . . . . . . 2598 00000093 ; POSI. . . . . . . . . . . . . . . . . . . . . . 2654 00000094 ; RPSI. . . . . . . . . . . . . . . . . . . . . . 2658 00000095 ; RTB . . . . . . . . . . . . . . . . . . . . . . 2662 00000096 ; TB. . . . . . . . . . . . . . . . . . . . . . . 2666 00000097 ; ARBN (ARBNO). . . . . . . . . . . . . . . . . . 2674 00000098 ; FARB (ARB Backup) . . . . . . . . . . . . . . . 2710 00000099 ; ATP (Cursor Position) . . . . . . . . . . . . . 2733 00000100 ; BAL . . . . . . . . . . . . . . . . . . . . . . 2766 00000101 ; STAR (Unevaluated Expression) . . . . . . . . . 2812 00000102 ; FNCE. . . . . . . . . . . . . . . . . . . . . . 2883 00000103 ; NME (Value Assignment). . . . . . . . . . . . . 2900 00000104 ; ENMI (Immediate Value Assignment) . . . . . . . 2962 00000105 ; SUCE (SUCCEED). . . . . . . . . . . . . . . . . 3016 00000106 ; 12. Defined Functions. . . . . . . . . . . . . . . . . 3035 00000107 ; DEFINE. . . . . . . . . . . . . . . . . . . . . 3039 00000108 ; DEFFNC (Invoke Defined Function). . . . . . . . 3106 00000109 ; 13. External Functions . . . . . . . . . . . . . . . . 3266 00000110 ; LOAD. . . . . . . . . . . . . . . . . . . . . . 3270 00000111 ; UNLOAD. . . . . . . . . . . . . . . . . . . . . 3345 00000112 ; LNKFNC (Link to External Function). . . . . . . 3357 00000113 ; 14. Arrays, Tables, and Defined Data Objects . . . . . 3430 00000114 ; ARRAY . . . . . . . . . . . . . . . . . . . . . 3434 00000115 ; ASSOC (TABLE) . . . . . . . . . . . . . . . . . 3504 00000116 ; DATDEF (DATA) . . . . . . . . . . . . . . . . . 3534 00000117 ; PROTO . . . . . . . . . . . . . . . . . . . . . 3594 00000118 ; ITEM (Array and Table References) . . . . . . . 3604 00000119 ; DEFDAT (Create Data Object) . . . . . . . . . . 3686 00000120 ; FIELD . . . . . . . . . . . . . . . . . . . . . 3735 00000121 ; 15. Input and Output . . . . . . . . . . . . . . . . . 3752 00000122 ; READ (INPUT). . . . . . . . . . . . . . . . . . 3756 00000123 ; PRINT (OUTPUT). . . . . . . . . . . . . . . . . 3789 00000124 ; BKSPCE. . . . . . . . . . . . . . . . . . . . . 3821 00000125 ; ENFILE. . . . . . . . . . . . . . . . . . . . . 3825 00000126 ; REWIND. . . . . . . . . . . . . . . . . . . . . 3829 00000127 ; DETACH. . . . . . . . . . . . . . . . . . . . . 3850 00000128 ; PUTIN . . . . . . . . . . . . . . . . . . . . . 3866 00000129 ; PUTOUT. . . . . . . . . . . . . . . . . . . . . 3890 00000130 ; 16. Tracing Procedures and Functions . . . . . . . . . 3907 00000131 ; TRACE . . . . . . . . . . . . . . . . . . . . . 3911 00000132 ; STOPTR. . . . . . . . . . . . . . . . . . . . . 3965 00000133 ; FENTR (Call Tracing). . . . . . . . . . . . . . 3993 00000134 ; KEYTR . . . . . . . . . . . . . . . . . . . . . 4062 00000135 ; TRPHND (Trace Handler). . . . . . . . . . . . . 4100 00000136 ; VALTR . . . . . . . . . . . . . . . . . . . . . 4125 00000137 ; 17. Other Operations . . . . . . . . . . . . . . . . . 4205 00000138 ; ASGN (=). . . . . . . . . . . . . . . . . . . . 4209 00000139 ; CON (Concatenation) . . . . . . . . . . . . . . 4254 00000140 ; IND (Indirect Reference). . . . . . . . . . . . 4346 00000141 ; KEYWRD. . . . . . . . . . . . . . . . . . . . . 4360 00000142 ; LIT . . . . . . . . . . . . . . . . . . . . . . 4385 00000143 ; NAME. . . . . . . . . . . . . . . . . . . . . . 4394 00000144 ; NMD (Value Assignment). . . . . . . . . . . . . 4406 00000145 ; STR (Unevaluated Expression). . . . . . . . . . 4446 00000146 ; 18. Other Predicates . . . . . . . . . . . . . . . . . 4453 00000147 ; DIFFER. . . . . . . . . . . . . . . . . . . . . 4457 00000148 ; IDENT . . . . . . . . . . . . . . . . . . . . . 4466 00000149 ; LGT . . . . . . . . . . . . . . . . . . . . . . 4475 00000150 ; NEG (\) . . . . . . . . . . . . . . . . . . . . 4491 00000151 ; QUES (?). . . . . . . . . . . . . . . . . . . . 4502 00000152 ; 19. Other Primitive Functions. . . . . . . . . . . . . 4507 00000153 ; APPLY . . . . . . . . . . . . . . . . . . . . . 4511 00000154 ; ARG . . . . . . . . . . . . . . . . . . . . . . 4530 00000155 ; LOCAL . . . . . . . . . . . . . . . . . . . . . 4539 00000156 ; FIELDS. . . . . . . . . . . . . . . . . . . . . 4544 00000157 ; CLEAR . . . . . . . . . . . . . . . . . . . . . 4581 00000158 ; COLLECT . . . . . . . . . . . . . . . . . . . . 4597 00000159 ; COPY. . . . . . . . . . . . . . . . . . . . . . 4607 00000160 ; CONVERT . . . . . . . . . . . . . . . . . . . . 4626 00000161 ; DATE. . . . . . . . . . . . . . . . . . . . . . 4795 00000162 ; DATATYPE. . . . . . . . . . . . . . . . . . . . 4804 00000163 ; DUMP. . . . . . . . . . . . . . . . . . . . . . 4820 00000164 ; DUPL. . . . . . . . . . . . . . . . . . . . . . 4885 00000165 ; OPSYN . . . . . . . . . . . . . . . . . . . . . 4907 00000166 ; REPLACE . . . . . . . . . . . . . . . . . . . . 4977 00000167 ; SIZE. . . . . . . . . . . . . . . . . . . . . . 5002 00000168 ; TIME. . . . . . . . . . . . . . . . . . . . . . 5013 00000169 ; TRIM. . . . . . . . . . . . . . . . . . . . . . 5024 00000170 ; 20. Common Code. . . . . . . . . . . . . . . . . . . . 5031 00000171 ; 21. Termination. . . . . . . . . . . . . . . . . . . . 5071 00000172 ; END . . . . . . . . . . . . . . . . . . . . . . 5072 00000173 ; FTLEND. . . . . . . . . . . . . . . . . . . . . 5078 00000174 ; SYSCUT. . . . . . . . . . . . . . . . . . . . . 5134 00000175 ; 22. Error Handling . . . . . . . . . . . . . . . . . . 5139 00000176 ; 23. Data . . . . . . . . . . . . . . . . . . . . . . . 5258 00000177 ; Pair Lists. . . . . . . . . . . . . . . . . . . 5259 00000178 ; Data Type Pairs . . . . . . . . . . . . . . . . 5381 00000179 ; Switches. . . . . . . . . . . . . . . . . . . . 5410 00000180 ; Constants . . . . . . . . . . . . . . . . . . . 5423 00000181 ; Pointers to Patterns. . . . . . . . . . . . . . 5454 00000182 ; Function Descriptors. . . . . . . . . . . . . . 5461 00000183 ; Miscellaneous Data. . . . . . . . . . . . . . . 5502 00000184 ; Program Pointers. . . . . . . . . . . . . . . . 5543 00000185 ; Pointers to Specifiers. . . . . . . . . . . . . 5552 00000186 ; Permanent Pair List Pointers. . . . . . . . . . 5560 00000187 ; Specifiers for Compilation. . . . . . . . . . . 5566 00000188 ; Strings and Specifiers. . . . . . . . . . . . . 5576 00000189 ; Character Buffers . . . . . . . . . . . . . . . 5611 00000190 ; Pointers to Pair Lists. . . . . . . . . . . . . 5620 00000191 ; Scratch Descriptors . . . . . . . . . . . . . . 5635 00000192 ; System Descriptors. . . . . . . . . . . . . . . 5670 00000193 ; Compiler Descriptors. . . . . . . . . . . . . . 5683 00000194 ; Data Pointers . . . . . . . . . . . . . . . . . 5701 00000195 ; Specifiers. . . . . . . . . . . . . . . . . . . 5711 00000196 ; Allocator Data. . . . . . . . . . . . . . . . . 5725 00000197 ; Machine Dependent Data. . . . . . . . . . . . . 5773 00000198 ; Function Table. . . . . . . . . . . . . . . . . 5779 00000199 ; Function Pair List. . . . . . . . . . . . . . . 5911 00000200 ; Function Initialization Data. . . . . . . . . . 6161 00000201 ; Pointers to Initialization Data . . . . . . . . 6258 00000202 ; System Arrays . . . . . . . . . . . . . . . . . 6280 00000203 ; String Storage Bin List . . . . . . . . . . . . 6304 00000204 ; Pattern-Matching History List . . . . . . . . . 6311 00000205 ; System Stack. . . . . . . . . . . . . . . . . . 6316 00000206 ; Primitive Patterns. . . . . . . . . . . . . . . 6321 00000207 ; Code Skeleton for TRACE . . . . . . . . . . . . 6414 00000208 ; Fatal Error Message Pointers. . . . . . . . . . 6448 00000209 ; Fatal Error Messages. . . . . . . . . . . . . . 6480 00000210 ; Compiler Error Messages . . . . . . . . . . . . 6511 00000211 ; Formats . . . . . . . . . . . . . . . . . . . . 6524 00000212 ; 00000213 ; 00000214 ; 00000215 ; 00000216 ; 00000217 ; 00000218 ; 00000219 ; 00000220 ; 00000221 ; 00000222 ; 00000223 ; 00000224 ; 00000225 ; 00000226 ; 00000227 ; 00000228 ; 00000229 ; 00000230 ; 00000231 ; 00000232 ; 00000233 ; 00000234 ; 00000235 ; 00000236 ; 00000237 ; 00000238 ; 00000239 ; 00000240 ; 00000241 ; 00000242 ; 00000243 ; 00000244 ; 00000245 ; 00000246 ; 00000247 ; 00000248 ; 00000249 ; 00000250 ; 00000251 .PAGE .SBTTL 'Linkage and Equivalences' ;00000252 COPY MLINK ;Linkage segment 00000253 COPY PARMS ;Machine-dependent parameters 00000254 ; 00000255 ; Constants 00000256 ; 00000257 ATTRIB = 2*DESCR ;Offset of label in string structure 00000258 LNKFLD = 3*DESCR ;Offset of link in string structure 00000259 BCDFLD = 4*DESCR ;Offset of string in string structure 00000260 FATHER = DESCR ;Offset of father in code node 00000261 LSON = 2*DESCR ;Offset of left son in code node 00000262 RSIB = 3*DESCR ;Offset of right sibling in code node 00000263 CODE = 4*DESCR ;Offset of code in code node 00000264 ESASIZ = 50 ;Limit on number of syntactic errors 00000265 FBLKSZ = 10*DESCR ;Size of function descriptor block 00000266 ARRLEN = 20 ;Limit on length of array print image 00000267 CARDSZ = 80 ;Width of compiler input 00000268 SEQSIZ = 8 ;Width of sequence field 00000269 STNOSZ = 8 ;Length of statement number field 00000270 DSTSZ = 2*STNOSZ ;Space for left and right numbering 00000271 CNODSZ = 4*DESCR ;Size of code node 00000272 DATSIZ = 1000 ;Limit on number of defined data type 00000273 EXTSIZ = 10 ;Default allocation for tables 00000274 NAMLSZ = 20 ;Growth quantum for name list 00000275 NODESZ = 3*DESCR ;Size of pattern node 00000276 OBSIZ = 256 ;Number of bin headers 00000277 OBARY = OBSIZ+3 ;Total number for bins 00000278 OCASIZ = 1500 ;Descriptors of initial object code 00000279 SPDLSZ = 1000 ;Descriptors of pattern stack 00000280 STSIZE = 1000 ;Descriptors of interpreter stack 00000281 SPDR = SPEC+DESCR ;Descriptor plus specifier 00000282 OBOFF = OBSIZ-2 ;Offset length in bins 00000283 SPDLDR = SPDLSZ*DESCR ;Size of pattern stack 00000284 ; 00000285 ; Equivalences 00000286 ; 00000287 ARYTYP = 7 ;Array reference 00000288 CLNTYP = 5 ;Goto field 00000289 CMATYP = 2 ;Comma 00000290 CMTTYP = 2 ;Comment card 00000291 CNTTYP = 4 ;Continue card 00000292 CTLTYP = 3 ;Control card 00000293 DIMTYP = 1 ;Dimension separator 00000294 EOSTYP = 6 ;End of statement 00000295 EQTYP = 4 ;Equal sign 00000296 FGOTYP = 3 ;Failure goto 00000297 FTOTYP = 6 ;Failure direct goto 00000298 FLITYP = 6 ;Literal real 00000299 FNCTYP = 5 ;Function call 00000300 ILITYP = 2 ;Literal integer 00000301 LPTYP = 1 ;Left parenthesis 00000302 NBTYP = 1 ;Nonbreak character 00000303 NEWTYP = 1 ;New statement 00000304 NSTTYP = 4 ;Parenthesized expression 00000305 QLITYP = 1 ;Quoted literal 00000306 RBTYP = 7 ;Right bracket 00000307 RPTYP = 3 ;Right parenthesis 00000308 SGOTYP = 2 ;Success goto 00000309 STOTYP = 5 ;Success direct goto 00000310 UGOTYP = 1 ;Unconditional goto 00000311 UTOTYP = 4 ;Unconditional direct goto 00000312 VARTYP = 3 ;Variable 00000313 ; 00000314 ; Data type Codes 00000315 ; 00000316 A = 4 ;ARRAY 00000317 B = 2 ;BLOCK (internal) 00000318 C = 8 ;CODE 00000319 E = 11 ;EXPRESSION 00000320 I = 6 ;INTEGER 00000321 K = 10 ;KEYWORD (NAME) 00000322 L = 12 ;LINKED STRING (internal) 00000323 N = 9 ;NAME 00000324 P = 3 ;PATTERN 00000325 R = 7 ;REAL 00000326 S = 1 ;STRING 00000327 T = 5 ;TABLE 00000328 ;---------------------------------------------------------------------* 00000329 .PAGE .SBTTL 'Program Initialization' ;00000330 .PSECT SNOBOL4_INITIALIZATION,SHR,LONG BEGIN: INIT , ;Initialize system 00000331 ISTACK , ;Initialize stack 00000332 OUTPUT OUTPUT,TITLEF ;Title listing 00000333 OUTPUT OUTPUT,SOURCF ;Print attribution 00000334 MSTIME TIMECL ;Time in compiler 00000335 RCALL SCBSCL,BLOCK,OCALIM;Allocate block for object code 00000336 MOVD OCSVCL,SCBSCL ;Save object code pointer 00000337 RESETF SCBSCL,PTR ;Clear pointer flag 00000338 GETSIZ YCL,INITLS ;Get size of initialization list 00000339 SPCNVT:GETD XPTR,INITLS,YCL ;Get pointer to list 00000340 GETSIZ XCL,XPTR ;Get size of list 00000341 SPCNV1:GETD ZPTR,XPTR,XCL ;Get pointer to specifier 00000342 AEQLC ZPTR,0,,SPCNV2 ;Skip dummy zero entries 00000343 RCALL ZPTR,GENVAR,ZPTR ;Convert specifier to structure 00000344 PUTD XPTR,XCL,ZPTR ;Replace pointer to specifier 00000345 SPCNV2:DECRA XCL,2*DESCR ;Decrement to next pair 00000346 ACOMPC XCL,0,SPCNV1 ;Continue if one remains 00000347 DECRA YCL,DESCR ;Decrement to next list 00000348 ACOMPC YCL,0,SPCNVT ;Continue if one remains 00000349 INITD1:GETDC XPTR,INITB,0 ;Get specifier to convert 00000350 RCALL YPTR,GENVAR, ;Convert it to string structure 00000351 GETDC ZPTR,INITB,DESCR ;Get location to put it 00000352 PUTDC ZPTR,0,YPTR ;Place pointer to string structure 00000353 INCRA INITB,2*DESCR ;Decrement to next pair 00000354 ACOMP INITB,INITE,,,INITD1 ;00000355 ; Compare with end 00000356 ; 00000357 PUTDC ABRTKY,DESCR,ABOPAT;Initial value of ABORT 00000358 PUTDC ARBKY,DESCR,ARBPAT ;Initial value of ARB 00000359 PUTDC BALKY,DESCR,BALPAT ;Initial value of BAL 00000360 PUTDC FAILKY,DESCR,FALPAT;Initial value of FAIL 00000361 PUTDC FNCEKY,DESCR,FNCPAT;Initial value of FENCE 00000362 PUTDC REMKY,DESCR,REMPAT ;Initial value of REM 00000363 PUTDC SUCCKY,DESCR,SUCPAT;Initial value of SUCCEED 00000364 ; 00000365 SETAC VARSYM,0 ;Set count of variables to zero 00000366 RCALL NBSPTR,BLOCK,NMOVER;Allocate block for value assignment 00000367 MOVD CMBSCL,SCBSCL ;Set up pointer for compiler 00000368 MOVD UNIT,INPUT ;Set up input unit 00000369 MOVD OCBSCL,CMBSCL ;Project base for interpreter 00000370 SUM OCLIM,CMBSCL,OCALIM;Compute end of code block 00000371 DECRA OCLIM,5*DESCR ;Leave room for overflow 00000372 SETAC INICOM,1 ;SIGNAL COMPLETION E3.10.6 BRANCH XLATRN ;00000373 ;_ 00000374 ;---------------------------------------------------------------------* 00000375 .PAGE .SBTTL 'Compilation and Interpreter Invocation' ;00000376 .PSECT SNOBOL4_INVOCATION,SHR,LONG XLATRD:AEQLC LISTCL,0,,XLATRN ;Skip print if list is off 00000377 STPRNT IOKEY,OUTBLK,LNBFSP;Print line image 00000378 XLATRN:STREAD INBFSP,UNIT,XLATRN,COMP5 ;00000379 SETSP TEXTSP,NEXTSP ;Read card and set up line 00000380 STREAM XSP,TEXTSP,CARDTB,COMP3,COMP3 ;00000381 ; Determine type of card 00000382 RCALL ,NEWCRD,,;Process card type 00000383 XLATNX:RCALL ,CMPILE,, ;00000384 ; Compile statement 00000385 INCRA CMOFCL,DESCR ;Increment offset 00000386 PUTD CMBSCL,CMOFCL,ENDCL;Insert END function 00000387 AEQLC LISTCL,0,,XLATP ;Skip print if list is off 00000388 STPRNT IOKEY,OUTBLK,LNBFSP;Print last line image 00000389 XLATP: AEQLC STYPE,EOSTYP,,XLAEND ;00000390 ; Finish on end of statement 00000391 STREAM XSP,TEXTSP,IBLKTB,COMP3,XLAEND ;00000392 ; Analyze END card 00000393 AEQLC STYPE,EOSTYP,,XLAEND ;00000394 ; Finish on end of statement 00000395 AEQLC STYPE,NBTYP,COMP7 ;Error if break character 00000396 STREAM XSP,TEXTSP,LBLTB,COMP7,COMP7 ;00000397 ; Analyze END label 00000398 RCALL XPTR,GENVAR, ;00000399 ; Generate variable for label 00000400 GETDC OCBSCL,XPTR,ATTRIB ;Get start for interpreter 00000401 AEQLC OCBSCL,0,,COMP7 ;Error if not attribute 00000402 AEQLC STYPE,EOSTYP,,XLAEND ;00000403 ; Finish on end of statement 00000404 STREAM XSP,TEXTSP,IBLKTB,COMP7,,COMP7 ;00000405 ; Analyze remainder of card 00000406 XLAEND:AEQLC ESAICL,0,,XLATSC ;Were there any compilation errors? 00000407 OUTPUT OUTPUT,ERRCF ;Print message of errors 00000408 BRANCH XLATND ;00000409 ;_ 00000410 XLATSC:OUTPUT OUTPUT,SUCCF ;Print message of no errors 00000411 XLATND:SETAC UNIT,0 ;Reset input unit 00000412 SETAC LPTR,0 ;Reset last label pointer 00000413 SETAC OCLIM,0 ;Reset limit on object code 00000414 ZERBLK COMREG,COMDCT ;Clear compiler descriptors 00000415 SUM XCL,CMBSCL,CMOFCL ;Compute end of object code 00000416 RCALL ,SPLIT, ;Split of unused part of block 00000417 SETAC LISTCL,0 ;Turn off listing switch 00000418 MSTIME ETMCL ;Time out compiler 00000419 SUBTRT TIMECL,ETMCL,TIMECL;Compute elapsed time 00000420 SETAC CNSLCL,1 ;Permit label redefinition 00000421 RCALL ,INTERP,, ;00000422 ; Call interpreter 00000423 ;_ 00000424 ;---------------------------------------------------------------------* 00000425 .PAGE .SBTTL 'Support Procedures' ;00000426 .PSECT SNOBOL4_SUPPORT,SHR,LONG ; 00000427 ; Augmentation of Pair Lists 00000428 ; 00000429 AUGATL:PROC , ;Procedure to augment pair lists 00000430 POP ;List, type and value 00000431 LOCAPT A4PTR,A1PTR,ZEROCL,AUG1 ;00000432 ; Look for hole in list 00000433 PUTDC A4PTR,DESCR,A2PTR ;Insert type descriptor 00000434 PUTDC A4PTR,2*DESCR,A3PTR;Insert value descriptor 00000435 MOVD A5PTR,A1PTR ;Set up return pointer 00000436 BRANCH A5RTN ;Return pair list 00000437 ;_ 00000438 AUG1: GETSIZ A4PTR,A1PTR ;Get size of present list 00000439 INCRA A4PTR,2*DESCR ;Add two more descriptors 00000440 SETVC A4PTR,B ;Insert BLOCK data type 00000441 RCALL A5PTR,BLOCK,A4PTR ;Allocate new block 00000442 PUTD A5PTR,A4PTR,A3PTR ;Insert value descriptor at end 00000443 DECRA A4PTR,DESCR ;Decrement 00000444 PUTD A5PTR,A4PTR,A2PTR ;Insert type descriptor above 00000445 AUGMOV:DECRA A4PTR,DESCR ;Adjust size 00000446 MOVBLK A5PTR,A1PTR,A4PTR ;Copy old list at top 00000447 BRANCH A5RTN ;Return new list 00000448 ;_ 00000449 ;---------------------------------------------------------------------* 00000450 ; 00000451 ; Code Skipping Procedure 00000452 ; 00000453 CODSKP:PROC , ;Procedure to skip object code 00000454 POP YCL ;Restore number of items to skip 00000455 CODCNT:INCRA OCICL,DESCR ;Increment offset 00000456 GETD XCL,OCBSCL,OCICL ;Get object code descriptor 00000457 TESTF XCL,FNC,,CODFNC ;Check for function 00000458 CODECR:DECRA YCL,1 ;Count down 00000459 ACOMPC YCL,0,CODCNT,RTN1,INTR10 ;00000460 ; Check for end 00000461 ;_ 00000462 CODFNC:PUSH YCL ;Save number to skip 00000463 SETAV YCL,XCL ;Get arguments to skip 00000464 RCALL ,CODSKP, ;Call self recursively 00000465 POP YCL ;Restore number to skip 00000466 BRANCH CODECR ;Go around again 00000467 ;_ 00000468 ;---------------------------------------------------------------------* 00000469 ; 00000470 ; Data Type Representation 00000471 ; 00000472 DTREP: PROC , ;Procedure to represent data type 00000473 POP A2PTR ;Restore object 00000474 VEQLC A2PTR,A,,DTARRY ;Is is ARRAY? 00000475 VEQLC A2PTR,T,,DTABLE ;Is it TABLE? 00000476 VEQLC A2PTR,R,DTREP1 ;Is it REAL? 00000477 REALST DPSP,A2PTR ;Convert REAL to STRING 00000478 BRANCH DTREPR ;Join end processing 00000479 ;_ 00000480 DTARRY:GETDC A3PTR,A2PTR,DESCR ;Get prototype 00000481 LOCSP ZSP,A3PTR ;Get specifier 00000482 GETLG A3PTR,ZSP ;Get length 00000483 ACOMPC A3PTR,ARRLEN,DTREP1;Check for excessive length 00000484 SETLC DTARSP,0 ;Clear specifier 00000485 APDSP DTARSP,ARRSP ;Append ARRAY 00000486 APDSP DTARSP,LPRNSP ;Append '(' 00000487 APDSP DTARSP,QTSP ;Append quote 00000488 APDSP DTARSP,ZSP ;Append prototype 00000489 APDSP DTARSP,QTSP ;Append quote 00000490 DTARTB:APDSP DTARSP,RPRNSP ;Append ')' 00000491 SETSP DPSP,DTARSP ;Move specifier 00000492 BRANCH DTREPR ;Return 00000493 ;_ 00000494 DTABLE:GETSIZ A3PTR,A2PTR ;E3.2.3 GETD A1PTR,A2PTR,A3PTR ;E3.2.3 DECRA A3PTR,DESCR ;E3.2.3 GETD A2PTR,A2PTR,A3PTR ;E3.2.3 DTABL1:AEQLC A1PTR,1,,DTABL2 ;E3.2.3 SUM A3PTR,A3PTR,A2PTR ;E3.2.3 DECRA A3PTR,2*DESCR ;E3.2.3 GETD A1PTR,A1PTR,A2PTR ;E3.2.3 BRANCH DTABL1 ;E3.2.3 ;_ E3.2.3 DTABL2:DECRA A3PTR,DESCR ;E3.2.3 DECRA A2PTR,2*DESCR ;E3.2.3 DIVIDE A3PTR,A3PTR,DSCRTW ;Divide to get item count 00000497 INTSPC ZSP,A3PTR ;Convert to string 00000498 SETLC DTARSP,0 ;Clear specifier 00000499 APDSP DTARSP,ASSCSP ;Append TABLE 00000500 APDSP DTARSP,LPRNSP ;Append '(' 00000501 APDSP DTARSP,ZSP ;Append size 00000502 APDSP DTARSP,CMASP ;Append comma 00000503 DIVIDE A2PTR,A2PTR,DSCRTW ;E3.2.3 INTSPC ZSP,A2PTR ;E3.2.3 APDSP DTARSP,ZSP ;Append extent 00000507 BRANCH DTARTB ;Join common processing 00000508 ;_ 00000509 DTREP1:MOVV DT1CL,A2PTR ;Insert data type 00000510 LOCAPT A3PTR,DTATL,DT1CL,DTREPE ;00000511 ; Look for data type name 00000512 GETDC A3PTR,A3PTR,2*DESCR;Get data type name 00000513 LOCSP DPSP,A3PTR ;Get specifier 00000514 DTREPR:RRTURN DPSPTR,1 ;Return pointer to specifier 00000515 ;_ 00000516 DTREPE:SETSP DPSP,EXDTSP ;Set up EXTERNAL specifier 00000517 BRANCH DTREPR ;Return 00000518 ;_ 00000519 ;---------------------------------------------------------------------* 00000520 ; 00000521 ; Location of Function Descriptor 00000522 ; 00000523 FINDEX:PROC , ;Procedure to get function descriptor 00000524 POP F1PTR ;Restore name 00000525 LOCAPV F2PTR,FNCPL,F1PTR,FATNF ;00000526 ; Look for function pair 00000527 GETDC F2PTR,F2PTR,DESCR ;Get function descriptor 00000528 FATBAK:RRTURN F2PTR,1 ;Return 00000529 ;_ 00000530 FATNF: INCRA NEXFCL,2*DESCR ;Increment function block offset 00000531 ACOMPC NEXFCL,FBLKSZ,FATBLK ;00000532 ; Check for end 00000533 FATNXT:SUM F2PTR,FBLOCK,NEXFCL;Compute position 00000534 RCALL FNCPL,AUGATL, ;00000535 ; Augment function pair list 00000536 PUTDC F2PTR,0,UNDFCL ;Insert undefined function 00000537 PUTDC F2PTR,DESCR,F1PTR ;Insert name 00000538 BRANCH FATBAK ;Join return 00000539 ;_ 00000540 FATBLK:RCALL FBLOCK,BLOCK,FBLKRQ;Allocate new function block 00000541 SETF FBLOCK,FNC ;Insert function flag 00000542 SETVC FBLOCK,0 ;Clear data type 00000543 SETAC NEXFCL,DESCR ;Initialize offset 00000544 BRANCH FATNXT ;Join processing 00000545 ;_ 00000546 ;---------------------------------------------------------------------* 00000547 .PAGE .SBTTL 'Storage Allocation and Regeneration Procedures' ;00000548 .PSECT SNOBOL4_GARBAGE,SHR,LONG ; 00000549 ; Allocation of Block 00000550 ; 00000551 BLOCK: PROC , ;Procedure to allocate blocks 00000552 POP ARG1CL ;Restore size to allocate 00000553 ACOMP ARG1CL,SIZLMT,SIZERR,SIZERR ;00000554 ; Check against size limit 00000555 BLOCK1:MOVD BLOCL,FRSGPT ;Position pointer to title 00000556 MOVV BLOCL,ARG1CL ;Move data type 00000557 INCRA FRSGPT,DESCR ;Leave room for title 00000558 SUM FRSGPT,FRSGPT,ARG1CL ;00000559 ; Move position pointer past end 00000560 ACOMP TLSGP1,FRSGPT,,,BLOGC ;00000561 ; Check for end of region 00000562 ZERBLK BLOCL,ARG1CL ;Clear block 00000563 PUTAC BLOCL,0,BLOCL ;Set up self-pointer in title 00000564 SETFI BLOCL,TTL ;Insert title flag 00000565 SETSIZ BLOCL,ARG1CL ;Insert block size 00000566 RRTURN BLOCL,1 ;Return pointer to block 00000567 ;_ 00000568 BLOGC: MOVA FRSGPT,BLOCL ;Restore position pointer 00000569 RCALL ,GC,, ;00000570 ; Regenerate storage 00000571 ;_ 00000572 ;---------------------------------------------------------------------* 00000573 ; 00000574 ; Generation of Natural Variables 00000575 ; 00000576 GENVAR:PROC , ;Procedure to generate variable 00000577 SETAC CONVSW,0 ;Note GENVAR entry 00000578 POP AXPTR ;Resotre pointer to specifier 00000579 GETSPC SPECR1,AXPTR,0 ;Get specifier 00000580 LEQLC SPECR1,0,,RT1NUL ;Avoid null string 00000581 LOCA1: VARID EQUVCL,SPECR1 ;Compute bin and ascension numbers 00000582 SUM BUKPTR,OBPTR,EQUVCL;Find bin 00000583 LOCA2: MOVD LSTPTR,BUKPTR ;Save working copy 00000584 GETAC BUKPTR,BUKPTR,LNKFLD ;00000585 ; Get link descriptor 00000586 AEQLC BUKPTR,0,,LOCA5 ;Check for end of chain 00000587 VCMPIC BUKPTR,LNKFLD,EQUVCL,LOCA5,,LOCA2 ;00000588 ; Compare ascension numbers 00000589 LOCSP SPECR2,BUKPTR ;Get specifier to string in storage 00000590 LEXCMP SPECR1,SPECR2,LOCA2,,LOCA2 ;00000591 ; Compare strings 00000592 MOVD LCPTR,BUKPTR ;Return string in storage 00000593 BRANCH LOCRET ;00000594 ;_ 00000595 LOCA5: GETLG AXPTR,SPECR1 ;Get length of string 00000596 GETLTH BKLTCL,AXPTR ;Compute space required 00000597 ACOMP BKLTCL,SIZLMT,SIZERR ;00000598 ; Check against size limit 00000599 LOCA7: MOVD LCPTR,FRSGPT ;Point to position in storage 00000600 SETVC LCPTR,S ;Set data type to STRING 00000601 INCRA FRSGPT,DESCR ;Leave space for title 00000602 SUM FRSGPT,FRSGPT,BKLTCL ;00000603 ; Skip required space 00000604 ACOMP TLSGP1,FRSGPT,,,LOCA4 ;00000605 ; Check for end of region 00000606 PUTDC LCPTR,0,ZEROCL ;Clear title 00000607 PUTAC LCPTR,0,LCPTR ;Point title to self 00000608 SETFI LCPTR,TTL+STTL ;Set string and title flags 00000609 SETSIZ LCPTR,AXPTR ;Insert size of string 00000610 AEQLC CONVSW,0,LOCA6 ;Check for GENVAR entry 00000611 PUTDC LCPTR,DESCR,NULVCL ;Set value to null string 00000612 PUTDC LCPTR,ATTRIB,ZEROCL;Set label attribute to zero 00000613 LOCSP SPECR2,LCPTR ;Get specifier to string structure 00000614 SETLC SPECR2,0 ;Clear length 00000615 APDSP SPECR2,SPECR1 ;Move new string in 00000616 LOCA6: PUTVC LCPTR,LNKFLD,EQUVCL;Insert ascension number 00000617 PUTAC LCPTR,LNKFLD,BUKPTR;Insert link pointer 00000618 PUTAC LSTPTR,LNKFLD,LCPTR;Link to last structure 00000619 INCRA VARSYM,1 ;Increment count of new variables 00000620 LOCRET:RRTURN LCPTR,1 ;Return pointer to structure 00000621 ;_ 00000622 LOCA4: MOVA FRSGPT,LCPTR ;Restore position pointer 00000623 RCALL ,GC,, ;00000624 ; Regenerate storage 00000625 ;_ 00000626 ;---------------------------------------------------------------------* 00000627 ; 00000628 ; Generation of Variable from Integer 00000629 ; 00000630 GNVARI:PROC GENVAR ;Procedure to generate string 00000631 SETAC CONVSW,0 ;Note GENVAR entry 00000632 POP AXPTR ;Restore integer 00000633 INTSPC SPECR1,AXPTR ;Convert to string 00000634 BRANCH LOCA1 ;Join processing 00000635 ;_ 00000636 ;---------------------------------------------------------------------* 00000637 ; 00000638 ; Allocation of Space for Variable 00000639 ; 00000640 CONVAR:PROC GENVAR ;Procedure to get space for variable 00000641 POP AXPTR ;Restore length 00000642 AEQLC AXPTR,0,,RT1NUL ;Avoid null string 00000643 SETAC CONVSW,1 ;Note CONVAR entry 00000644 GETLTH BKLTCL,AXPTR ;Get space required 00000645 ACOMP BKLTCL,SIZLMT,SIZERR ;00000646 ; Check against size limit 00000647 SUM TEMPCL,FRSGPT,BKLTCL ;00000648 ; Skip required space 00000649 INCRA TEMPCL,DESCR ;Save space for title 00000650 ACOMP TLSGP1,TEMPCL,,,CONVR4 ;00000651 ; Check for end of region 00000652 CONVR5:PUTDC FRSGPT,0,ZEROCL ;Clear title 00000653 PUTAC FRSGPT,0,FRSGPT ;Set up self pointer 00000654 SETFI FRSGPT,TTL+STTL ;Set string and title flags 00000655 SETSIZ FRSGPT,AXPTR ;Insert tentative size of string 00000656 PUTDC FRSGPT,DESCR,NULVCL;Insert null string as value 00000657 PUTDC FRSGPT,ATTRIB,ZEROCL ;00000658 ; Set label to zero 00000659 MOVA BKLTCL,FRSGPT ;E3.3.2 RRTURN BKLTCL,1 ;E3.3.2 ;_ 00000661 CONVR4:RCALL ,GC,BKLTCL, ;00000662 ; Regenerate storage 00000663 ;_ 00000664 ;---------------------------------------------------------------------* 00000665 ; 00000666 ; Generation of Variable in Place 00000667 ; 00000668 GNVARS:PROC GENVAR ;Procedure to entry string 00000669 POP AXPTR ;Restore length 00000670 AEQLC AXPTR,0,,RT1NUL ;Avoid null string 00000671 LOCSP SPECR1,FRSGPT ;Get specifier to position 00000672 PUTLG SPECR1,AXPTR ;Insert final length 00000673 SETSIZ FRSGPT,AXPTR ;Insert size in title 00000674 BRANCH LOCA1 ;Join processing 00000675 ;_ 00000676 ;---------------------------------------------------------------------* 00000677 ; 00000678 ; Storage Regeneration 00000679 ; 00000680 GC: PROC , ;Storage regeneration procedure 00000681 POP GCREQ ;Restore space required 00000682 PSTACK BLOCL ;Post stack position 00000683 SUBTRT BLOCL,BLOCL,STKPTR ;Compute stack length used 00000684 SETSIZ STKPTR,BLOCL ;Set stack size 00000685 MOVD BKDXU,PRMDX ;Number of resident blocks 00000686 GCT: GETD GCMPTR,PRMPTR,BKDXU;Get next resident block 00000687 AEQLC GCMPTR,0,,GCTDWN ;Skip nonpointers 00000688 RCALL ,GCM, ;Scan resident block 00000689 GCTDWN:DECRA BKDXU,DESCR ;Decrement block count 00000690 AEQLC BKDXU,0,GCT ;Test for end of loop 00000691 SETAC BKPTR,OBLIST-DESCR ;Set up pointer to bins 00000692 GCBA1: ACOMP BKPTR,OBEND,GCLAD ;Check for end of bins 00000693 INCRA BKPTR,DESCR ;Increment bin pointer 00000694 MOVD ST1PTR,BKPTR ;Get working copy 00000695 GCBA2: GETAC ST1PTR,ST1PTR,LNKFLD ;00000696 ; Get link pointer 00000697 AEQLC ST1PTR,0,,GCBA1 ;Test for end of chain 00000698 TESTFI ST1PTR,MARK,,GCBA2 ;Test for marked structure 00000699 GETDC ST2PTR,ST1PTR,DESCR;Get value descriptor 00000700 DEQL ST2PTR,NULVCL,GCBA4;Mark if nonnull 00000701 AEQLIC ST1PTR,ATTRIB,0,,GCBA2 ;00000702 ; Test attribute also 00000703 GCBA4: PUTDC GCBLK,DESCR,ST1PTR ;Set up pseudoblock 00000704 RCALL ,GCM,,GCBA2 ;Mark string structure 00000705 ;_ 00000706 GCLAD: MOVD CPYCL,HDSGPT ;Initialize target pointer 00000707 MOVD TTLCL,HDSGPT ;Initialize block pointer 00000708 GCLAD0:BKSIZE BKDX,TTLCL ;Get size of block 00000709 TESTFI TTLCL,MARK,GCLAD7 ;Is the block marked? 00000710 SUM CPYCL,CPYCL,BKDX ;Is block marked? 00000711 SUM TTLCL,TTLCL,BKDX ;Update block pointer 00000712 AEQL TTLCL,FRSGPT,GCLAD0,GCBB1 ;00000713 ; Check for end of region 00000714 ;_ 00000715 GCLAD7:MOVD MVSGPT,TTLCL ;Update compression barrier 00000716 GCLAD4:SUM TTLCL,TTLCL,BKDX ;Update block pointer 00000717 AEQL TTLCL,FRSGPT,,GCBB1;Check for end of region 00000718 BKSIZE BKDX,TTLCL ;Get size of block 00000719 TESTFI TTLCL,MARK,GCLAD4 ;Is block marked? 00000720 PUTAC TTLCL,0,CPYCL ;Point title to target 00000721 SUM CPYCL,CPYCL,BKDX ;Update target pointer 00000722 BRANCH GCLAD4 ;Continue 00000723 ;_ 00000724 GCBB1: SETAC BKPTR,OBLIST-DESCR ;Set up pointer to bins 00000725 SETAC NODPCL,1 ;No dump while reorganizing 00000726 GCBB2: ACOMP BKPTR,OBEND,GCLAP ;Check for end of bins 00000727 INCRA BKPTR,DESCR ;Increment bin pointer 00000728 MOVD ST1PTR,BKPTR ;Get work copy 00000729 GCBB3: MOVD ST2PTR,ST1PTR ;Save pointer to be linked 00000730 GCBB4: GETAC ST1PTR,ST1PTR,LNKFLD ;00000731 ; Get link pointer 00000732 AEQLC ST1PTR,0,,GCBB5 ;Check for end of chain 00000733 TESTFI ST1PTR,MARK,GCBB4 ;Is string marked? 00000734 GETAC BLOCL,ST1PTR,0 ;Get target address 00000735 PUTAC ST2PTR,LNKFLD,BLOCL;Set link to target 00000736 BRANCH GCBB3 ;Continue 00000737 ;_ 00000738 GCBB5: PUTAC ST2PTR,LNKFLD,ZEROCL ;00000739 ; Set last link to zero 00000740 BRANCH GCBB2 ;Continue 00000741 ;_ 00000742 GCLAP: MOVD TTLCL,HDSGPT ;Initialize target pointer 00000743 GCLAP0:BKSIZE BKDXU,TTLCL ;Get size of block 00000744 TESTFI TTLCL,STTL,,GCLAP1 ;Check for string 00000745 MOVD BKDX,BKDXU ;Working copy of block size 00000746 BRANCH GCLAP2 ;00000747 ;_ 00000748 GCLAP1:SETAC BKDX,3*DESCR ;Three descriptors for string 00000749 GCLAP2:TESTFI TTLCL,MARK,GCLAP5 ;Is block marked? 00000750 DECRA BKDX,DESCR ;Decrement offset 00000751 GCLAP3:GETD DESCL,TTLCL,BKDX ;Get next descriptor in block 00000752 TESTF DESCL,PTR,GCLAP4 ;Is it a pointer? 00000753 ACOMP DESCL,MVSGPT,,,GCLAP4 ;00000754 ; Is it above compression barrier? 00000755 TOP TOPCL,OFSET,DESCL ;Compute offset to target 00000756 ADJUST DESCL,TOPCL,OFSET ;Adjust pointer to target 00000757 PUTD TTLCL,BKDX,DESCL ;Put descriptor back in block 00000758 GCLAP4:DECRA BKDX,DESCR ;Decrement offset 00000759 AEQLC BKDX,0,GCLAP3 ;Check for end of block 00000760 GCLAP5:SUM TTLCL,TTLCL,BKDXU ;Move to next block 00000761 AEQL TTLCL,FRSGPT,GCLAP0;Check for end of region 00000762 MOVD BKDXU,PRMDX ;Number of resident blocks 00000763 GCLAT1:GETD TTLCL,PRMPTR,BKDXU ;Get next resident block 00000764 AEQLC TTLCL,0,,GCLAT4 ;Skip nonpointer 00000765 GETSIZ BKDX,TTLCL ;Get size of block 00000766 GCLAT2:GETD DESCL,TTLCL,BKDX ;Get descriptor from block 00000767 TESTF DESCL,PTR,GCLAT3 ;Is it a pointer? 00000768 ACOMP DESCL,MVSGPT,,,GCLAT3 ;00000769 ; Is it above compression barrier? 00000770 TOP TOPCL,OFSET,DESCL ;Compute offset to target 00000771 ADJUST DESCL,TOPCL,OFSET ;Adjust pointer to target 00000772 PUTD TTLCL,BKDX,DESCL ;Put descriptor back in block 00000773 GCLAT3:DECRA BKDX,DESCR ;Decrement offset 00000774 AEQLC BKDX,0,GCLAT2 ;Check for end of block 00000775 GCLAT4:DECRA BKDXU,DESCR ;Decrement count of resident blocks 00000776 AEQLC BKDXU,0,GCLAT1 ;Check for end of resident blocks 00000777 MOVD TTLCL,HDSGPT ;Set up target pointer 00000778 GCLAM0:BKSIZE BKDXU,TTLCL ;Get size of block 00000779 ACOMP TTLCL,MVSGPT,GCLAM5,GCLAM5 ;00000780 ; Has compression barrier been reached 00000781 GETAC TOPCL,TTLCL,0 ;Get target position 00000782 MOVDIC TOPCL,0,TTLCL,0 ;Move title to target position 00000783 RSETFI TOPCL,MARK ;Clear mark flag 00000784 BRANCH GCLAM4 ;Continue 00000785 ;_ 00000786 GCLAM5:MOVA BKDX,BKDXU ;Working copy of block size 00000787 DECRA BKDX,DESCR ;Size to be moved 00000788 TESTFI TTLCL,MARK,GCLAM4 ;Is block marked? 00000789 GETAC TOPCL,TTLCL,0 ;Get target position 00000790 MOVDIC TOPCL,0,TTLCL,0 ;Move title 00000791 RSETFI TOPCL,MARK ;Clear mark flag 00000792 MOVBLK TOPCL,TTLCL,BKDX ;Move block itself 00000793 GCLAM4:SUM TTLCL,TTLCL,BKDXU ;Get to next block 00000794 AEQL TTLCL,FRSGPT,GCLAM0;Check for end of region 00000795 INCRA GCNO,1 ;Increment count of regenerations 00000796 SETAC NODPCL,0 ;Permit dump 00000797 BKSIZE BKDX,TOPCL ;Get size of last block 00000798 SUM FRSGPT,TOPCL,BKDX ;Compute new allocation pointer 00000799 RESETF FRSGPT,FNC ;Clear possible function flag 00000800 SUBTRT GCGOT,TLSGP1,FRSGPT;Compute amount reclaimed 00000801 DECRA GCGOT,DESCR ;00000802 RESETF GCGOT,PTR ;Clear pointer flag 00000803 ACOMP GCREQ,GCGOT,FAIL ;Compare with amount required 00000804 RRTURN GCGOT,2 ;00000805 ;_ 00000806 ;---------------------------------------------------------------------* 00000807 ; 00000808 ; Block Marking 00000809 ; 00000810 GCM: PROC , ;Procedure to mark blocks 00000811 POP BK1CL ;Restore block to mark from 00000812 PUSH ZEROCL ;Save end marker 00000813 GCMA1: GETSIZ BKDX,BK1CL ;Get size of block 00000814 GCMA2: GETD DESCL,BK1CL,BKDX ;Get descriptor 00000815 TESTF DESCL,PTR,GCMA3 ;Is it a pointer? 00000816 AEQLC DESCL,0,,GCMA3 ;Is address zero? 00000817 TOP TOPCL,OFSET,DESCL ;Get to title of block pointed to 00000818 TESTFI TOPCL,MARK,GCMA4 ;Is block marked? 00000819 GCMA3: DECRA BKDX,DESCR ;Decrement offset 00000820 AEQLC BKDX,0,GCMA2 ;Check for end of block 00000821 POP BK1CL ;Restore block pushed 00000822 AEQLC BK1CL,0,,RTN1 ;Check for end 00000823 SETAV BKDX,BK1CL ;Get size remaining 00000824 BRANCH GCMA2 ;Continue processing 00000825 ;_ 00000826 GCMA4: DECRA BKDX,DESCR ;Decrement offset 00000827 AEQLC BKDX,0,,GCMA9 ;Check for end 00000828 SETVA BK1CL,BKDX ;Insert offset 00000829 PUSH BK1CL ;Save current block 00000830 GCMA9: MOVD BK1CL,TOPCL ;Set poiner to new block 00000831 SETFI BK1CL,MARK ;Mark block 00000832 TESTFI BK1CL,STTL,GCMA1 ;Is it a string? 00000833 MOVD BKDX,TWOCL ;Set size of string to 2 00000834 BRANCH GCMA2 ;Join processing 00000835 ;_ 00000836 ;---------------------------------------------------------------------* 00000837 ; 00000838 ; Procedure to Split Blocks 00000839 SPLIT: PROC , ;Procedure to split blocks 00000840 POP A4PTR ;Restore pointer to middle of block 00000841 TOP A5PTR,A6PTR,A4PTR ;Get title and offset 00000842 AEQLC A6PTR,0,,RTN1 ;Avoid block of zero length 00000843 GETSIZ A7PTR,A5PTR ;Get present block size 00000844 SUBTRT A7PTR,A7PTR,A6PTR ;Subtract offset 00000845 DECRA A7PTR,DESCR ;Decrement for title 00000846 ACOMPC A7PTR,0,,RTN1,RTN1 ;Avoid block of zero length 00000847 SETSIZ A5PTR,A6PTR ;Reset size of old block 00000848 INCRA A4PTR,DESCR ;Adjust pointer to middle 00000849 PUTDC A4PTR,0,ZEROCL ;00000850 PUTAC A4PTR,0,A4PTR ;00000851 SETFI A4PTR,TTL ;Insert title flag 00000852 SETSIZ A4PTR,A7PTR ;Insert size fo new block 00000853 BRANCH RTN1 ;Return 00000854 ;_ 00000855 ;---------------------------------------------------------------------* 00000856 .PAGE .SBTTL 'Compilation Procedures' ;00000857 .PSECT SNOBOL4_COMPILATION,SHR,LONG ; 00000858 ; Binary Operator Analysis 00000859 ; 00000860 BINOP: PROC , ;Compiler binary operator analysis 00000861 RCALL ,FORBLK,,BINOP1 ;Test for initial blank 00000862 AEQLC BRTYPE,NBTYP,RTN2 ;If so, fail on break 00000863 STREAM XSP,TEXTSP,BIOPTB,BINCON ;00000864 MOVD ZPTR,STYPE ;Move function descriptor 00000865 BRANCH RTZPTR ;Return function descriptor 00000866 ;_ 00000867 BINOP1:RCALL ,FORWRD,,COMP3 ;If no blank, find character 00000868 SELBRA BRTYPE,<,RTN2,RTN2,,,RTN2,RTN2> ;00000869 BINERR:SETAC EMSGCL,ILLBIN ;Set up error message 00000870 BRANCH RTN1 ;Take error return 00000871 ;_ 00000872 BINCON:MOVD ZPTR,CONCL ;No operator, concatenation 00000873 BRANCH RTZPTR ;Return function descriptor 00000874 ;_ 00000875 BINEOS:SETAC EMSGCL,ILLEOS ;Set up error message 00000876 BRANCH RTN1 ;Error return 00000877 ;_ 00000878 ;---------------------------------------------------------------------* 00000879 ; 00000880 ; Statement Compilation 00000881 ; 00000882 CMPILE:PROC , ;Procedure to compile statement 00000883 SETAC BRTYPE,0 ;Clear break indicator 00000884 MOVD BOSCL,CMOFCL ;Set statement beginning offset 00000885 INCRA CSTNCL,1 ;Increment statement number 00000886 STREAM XSP,TEXTSP,LBLTB,CERR1 ;00000887 ; Break out label 00000888 LEQLC XSP,0,,CMPILA ;Check for no label 00000889 INCRA CMOFCL,DESCR ;Increment offset 00000890 PUTD CMBSCL,CMOFCL,BASECL ;00000891 ; Insert BASE function 00000892 SUM CMBSCL,CMBSCL,CMOFCL ;00000893 ; Add offset to base 00000894 ACOMP CMBSCL,OCLIM,,,CMPILO ;00000895 ; Check for end of object code 00000896 RCALL XCL,BLOCK,CODELT ;Get block for more 00000897 PUTDC CMBSCL,0,GOTGCL ;Replace BASE with direct goto 00000898 PUTDC CMBSCL,DESCR,LIT1CL ;E3.7.1 PUTDC CMBSCL,2*DESCR,XCL ;Aim at new block 00000900 MOVD CMBSCL,XCL ;Set up base of new region 00000901 SUM OCLIM,CMBSCL,CODELT;Compute end of new block 00000902 DECRA OCLIM,5*DESCR ;Leave safety factor 00000903 PUTDC CMBSCL,DESCR,BASECL;Set BASE function in new region 00000904 INCRA CMBSCL,DESCR ;Increment base 00000905 CMPILO:SETAC CMOFCL,0 ;Zero offset 00000906 SETAC BOSCL,0 ;Zero base offset 00000907 RCALL LPTR,GENVAR,XSPPTR ;Get variable for label 00000908 AEQLIC LPTR,ATTRIB,0,,CMPILC ;00000909 ; Check for previous definition 00000910 AEQLC CNSLCL,0,,CERR2 ;Check for label redefinition 00000911 CMPILC:PUTDC LPTR,ATTRIB,CMBSCL ;Insert label attribute 00000912 DEQL LPTR,ENDPTR,,RTN2 ;Check for END 00000913 CMPILA:RCALL ,FORBLK,,CERR12 ;Get to next character 00000914 AEQLC BRTYPE,EOSTYP,,RTN3;Was end of statement founc? 00000915 INCRA CMOFCL,DESCR ;Increment offset 00000916 PUTD CMBSCL,CMOFCL,INITCL ;00000917 ; Insert INIT function 00000918 INCRA CMOFCL,DESCR ;Increment offset 00000919 MOVD FRNCL,CMOFCL ;Save offset for failure position 00000920 AEQLC BRTYPE,NBTYP,,CMPSUB ;00000921 ; Check for nonbreak 00000922 AEQLC BRTYPE,CLNTYP,CERR3,CMPGO ;00000923 ; Check for goto field 00000924 ;_ 00000925 CMPSUB:RCALL SUBJND,ELEMNT,, ;00000926 ; Compiler subject 00000927 RCALL ,FORBLK,,CERR5 ;Get to next character 00000928 AEQLC BRTYPE,NBTYP,,CMPATN ;00000929 ; Check for nonbreak 00000930 AEQLC BRTYPE,EQTYP,,CMPFRM ;00000931 ; Check for assignment 00000932 RCALL ,TREPUB, ;Copy subject into object code 00000933 AEQLC BRTYPE,CLNTYP,,CMPGO ;00000934 ; Check for goto 00000935 AEQLC BRTYPE,EOSTYP,CERR5,CMPNGO ;00000936 ; Check for end of statement 00000937 ;_ 00000938 CMPATN:RCALL PATND,EXPR,,CDIAG ;Compile pattern 00000939 AEQLC BRTYPE,EQTYP,,CMPASP ;00000940 ; Check for replacement 00000941 INCRA CMOFCL,DESCR ;Increment offset 00000942 PUTD CMBSCL,CMOFCL,SCANCL ;00000943 ; Insert SCAN function 00000944 RCALL ,TREPUB, ;Copy subject into object code 00000945 RCALL ,TREPUB, ;Copy pattern into object code 00000946 CMPTGO:AEQLC BRTYPE,EOSTYP,,CMPNGO ;00000947 ; Check for end of statement 00000948 AEQLC BRTYPE,CLNTYP,CERR5,CMPGO ;00000949 ; Check for end of statement 00000950 ;_ 00000951 CMPFRM:RCALL FORMND,EXPR,,CDIAG ;Compile object 00000952 INCRA CMOFCL,DESCR ;Increment offset 00000953 PUTD CMBSCL,CMOFCL,ASGNCL ;00000954 ; Insert ASGN function 00000955 RCALL ,TREPUB, ;Copy subject into object code 00000956 BRANCH CMPFT ;Join object publication 00000957 ;_ 00000958 CMPASP:RCALL FORMND,EXPR,,CDIAG ;Compile object 00000959 INCRA CMOFCL,DESCR ;Increment offset 00000960 PUTD CMBSCL,CMOFCL,SJSRCL ;00000961 ; Insert SJSR function 00000962 RCALL ,TREPUB, ;Copy subject into object code 00000963 RCALL ,TREPUB, ;Copy pattern into object code 00000964 CMPFT: RCALL ,TREPUB,FORMND,CMPTGO ;00000965 ; Copy object into object code 00000966 ;_ 00000967 CMPNGO:SETVA CSTNCL,CMOFCL ;Set up offset for failure 00000968 PUTD CMBSCL,FRNCL,CSTNCL;Insert argument of INIT 00000969 BRANCH RTN3 ;Statement compilation is done 00000970 ;_ Get to next character 00000971 CMPGO: RCALL ,FORWRD,,COMP3 ;Check for end of statement 00000972 AEQLC BRTYPE,EOSTYP,,CMPNGO ;00000973 ; Check for nonbreak 00000974 AEQLC BRTYPE,NBTYP,CERR11 ;00000975 STREAM XSP,TEXTSP,GOTOTB,CERR11,CERR12 ;00000976 ; Analyze goto field 00000977 MOVD GOGOCL,GOTLCL ;Predict GOTL 00000978 SETAC GOBRCL,RPTYP ;Set up predicted closing break 00000979 ACOMP STYPE,GTOCL,,CMPGG,CMPGG ;00000980 ; Check for direct goto 00000981 MOVD GOGOCL,GOTGCL ;Set up direct goto 00000982 SETAC GOBRCL,RBTYP ;Set up closing break 00000983 CMPGG: SELBRA STYPE,<,CMPSGO,CMPFGO,,CMPSGO,CMPFGO> ;00000984 ; Branch on type 00000985 CMPUGO:SETVA CSTNCL,CMOFCL ;Set up offset for failure 00000986 PUTD CMBSCL,FRNCL,CSTNCL;Insert argument of INIT 00000987 RCALL GOTOND,EXPR,,CDIAG ;Compile goto 00000988 AEQL BRTYPE,GOBRCL,CERR11 ;00000989 ; Verify closing break 00000990 INCRA CMOFCL,DESCR ;Increment offset 00000991 PUTD CMBSCL,CMOFCL,GOGOCL ;00000992 ; Insert goto function 00000993 RCALL ,TREPUB, ;Copy goto into object code 00000994 RCALL ,FORWRD,,COMP3 ;Get to next character 00000995 AEQLC BRTYPE,EOSTYP,CERR11,RTN3 ;00000996 ; Check for end of statement 00000997 ;_ 00000998 CMPSGO:RCALL SGOND,EXPR,,CDIAG ;Compile success goto 00000999 AEQL BRTYPE,GOBRCL,CERR11 ;00001000 ; Verify break character 00001001 INCRA CMOFCL,DESCR ;Increment offset 00001002 PUTD CMBSCL,CMOFCL,GOGOCL ;00001003 ; Insert goto function 00001004 RCALL ,TREPUB, ;Copy goto into object code 00001005 RCALL ,FORWRD,,COMP3 ;Get to next character 00001006 AEQLC BRTYPE,EOSTYP,CMPILL ;00001007 ; Check for end of statement 00001008 SETVA CSTNCL,CMOFCL ;Set up offset for failure 00001009 PUTD CMBSCL,FRNCL,CSTNCL;Insert argument of INIT 00001010 BRANCH RTN3 ;Compilation is complete, return 00001011 ;_ 00001012 CMPILL:AEQLC BRTYPE,NBTYP,CERR11;Check for nonbreak 00001013 STREAM XSP,TEXTSP,GOTOTB,CERR11,CERR12 ;00001014 ; Analyze goto field 00001015 AEQLC STYPE,FGOTYP,CMPFTC;Check for failure goto 00001016 MOVD GOGOCL,GOTLCL ;Set up goto 00001017 SETAC GOBRCL,RPTYP ;Set up closing break 00001018 BRANCH CMPUGO ;Join processing 00001019 ;_ 00001020 CMPFTC:AEQLC STYPE,FTOTYP,CERR11;Verify failure goto 00001021 MOVD GOGOCL,GOTGCL ;Set up goto 00001022 SETAC GOBRCL,RBTYP ;Set up closing break 00001023 BRANCH CMPUGO ;Join processing 00001024 ;_ 00001025 CMPFGO:RCALL FGOND,EXPR,,CDIAG ;Compile failure goto 00001026 AEQL BRTYPE,GOBRCL,CERR11 ;00001027 ; Verify failure goto 00001028 RCALL ,FORWRD,,COMP3 ;Get to next character 00001029 AEQLC BRTYPE,EOSTYP,CMPILM ;00001030 ; Check for end of statement 00001031 INCRA CMOFCL,DESCR ;Increment offset 00001032 PUTD CMBSCL,CMOFCL,GOTOCL ;00001033 ; Insert goto function 00001034 INCRA CMOFCL,DESCR ;Increment offset 00001035 MOVD SRNCL,CMOFCL ;Save location for success 00001036 SETVA CSTNCL,CMOFCL ;Set up failure offset 00001037 PUTD CMBSCL,FRNCL,CSTNCL;Insert argument of INIT 00001038 INCRA CMOFCL,DESCR ;Increment offset 00001039 PUTD CMBSCL,CMOFCL,GOGOCL ;00001040 ; Insert goto function 00001041 RCALL ,TREPUB, ;Copy goto into object code 00001042 PUTD CMBSCL,SRNCL,CMOFCL;Insert success offset into code 00001043 BRANCH RTN3 ;Compilation is complete, return 00001044 ;_ 00001045 CMPILM:AEQLC BRTYPE,NBTYP,CERR11;Verify nonbreak 00001046 STREAM XSP,TEXTSP,GOTOTB,CERR11,CERR12 ;00001047 ; Analyze goto field 00001048 AEQLC STYPE,SGOTYP,CMPSTC;Check for success goto 00001049 PUSH GOTLCL ;Save goto type 00001050 SETAC GOBRCL,RPTYP ;Set up closing break 00001051 BRANCH CMPILN ;Join processing 00001052 ;_ 00001053 CMPSTC:AEQLC STYPE,STOTYP,CERR11;Verify success goto 00001054 PUSH GOTGCL ;Save goto type 00001055 SETAC GOBRCL,RBTYP ;Set up closing break 00001056 CMPILN:RCALL SGOND,EXPR,,CDIAG ;Compile success goto 00001057 AEQL BRTYPE,GOBRCL,CERR11 ;00001058 ; Verify closing break 00001059 RCALL ,FORWRD,,COMP3 ;Get to next character 00001060 AEQLC BRTYPE,EOSTYP,CERR11 ;00001061 ; Verify end of statement 00001062 INCRA CMOFCL,DESCR ;Increment offset 00001063 POP WCL ;Restore goto type 00001064 PUTD CMBSCL,CMOFCL,WCL ;Insert goto function 00001065 RCALL ,TREPUB, ;Copy goto into object code 00001066 SETVA CSTNCL,CMOFCL ;Set up failure offset 00001067 PUTD CMBSCL,FRNCL,CSTNCL;Insert argument of INIT 00001068 INCRA CMOFCL,DESCR ;Increment offset 00001069 PUTD CMBSCL,CMOFCL,GOGOCL ;00001070 ; Insert goto function 00001071 RCALL ,TREPUB,,RTN3 ;00001072 ; Copy goto into object code 00001073 ;_ 00001074 CERR1: SETAC EMSGCL,EMSG1 ;Erroneous label 00001075 BRANCH CDIAG ;00001076 ;_ 00001077 CERR2: SETAC EMSGCL,EMSG2 ;Multidefined label 00001078 BRANCH CDIAG ;00001079 ;_ 00001080 CERR3: SETAC EMSGCL,EMSG3 ;Break character before subject 00001081 BRANCH CDIAG ;00001082 ;_ 00001083 CERR5: SETAC EMSGCL,ILLBRK ;Illegal character after pattern 00001084 BRANCH CDIAG ;00001085 ;_ 00001086 CERR12:SETAC EMSGCL,ILLEOS ;Illegal statement termination 00001087 BRANCH CDIAG ;00001088 ;_ 00001089 CERR11:SETAC EMSGCL,EMSG14 ;Characters after goto 00001090 CDIAG: INCRA BOSCL,DESCR ;Increment offset of beginning 00001091 PUTD CMBSCL,BOSCL,ERORCL;Insert ERROR function 00001092 INCRA BOSCL,DESCR ;Increment offset 00001093 PUTD CMBSCL,BOSCL,CSTNCL;Insert argument of ERROR 00001094 MOVD CMOFCL,BOSCL ;Reposition offset 00001095 INCRA ESAICL,DESCR ;Increment count of errors 00001096 ACOMP ESAICL,ESALIM,COMP9;Test for excessive errors 00001097 AEQLC LISTCL,0,,CDIAG1 ;Check for listing mode 00001098 MOVD YCL,ERRBAS ;Set up length of error vector 00001099 AEQLC BRTYPE,EOSTYP,,CDIAG3 ;00001100 ; Check for end of statement 00001101 GETLG XCL,TEXTSP ;Get length remaining 00001102 SUBTRT YCL,YCL,XCL ;Compute position for marker 00001103 CDIAG3:PUTLG ERRSP,YCL ;Insert length 00001104 APDSP ERRSP,QTSP ;Set in marker 00001105 AEQLC BRTYPE,EOSTYP,,CDIAG2 ;00001106 ; Check for end of statement 00001107 STPRNT IOKEY,OUTBLK,LNBFSP;Print statement 00001108 CDIAG2:STPRNT IOKEY,OUTBLK,ERRSP ;Print error marker 00001109 PUTLG ERRSP,YCL ;Insert length in marker 00001110 APDSP ERRSP,BLSP ;Blank out marker 00001111 GETSPC TSP,EMSGCL,0 ;Get error message 00001112 SETLC CERRSP,0 ;Clear specifier 00001113 APDSP CERRSP,STARSP ;Append attention getter 00001114 APDSP CERRSP,TSP ;Append error message 00001115 STPRNT IOKEY,OUTBLK,CERRSP;Print error message 00001116 STPRNT IOKEY,OUTBLK,BLSP ;Print blank line 00001117 CDIAG1:AEQLC UNIT,0,,RTN1 ;E3.0.1 AEQLC BRTYPE,EOSTYP,,RTN3 ;E3.0.1 STREAM XSP,TEXTSP,EOSTB,COMP3,,RTN3 ;00001120 ; Get to end of statement 00001121 DIAGRN:STREAD INBFSP,UNIT,DIAGRN,COMP5 ;00001122 ; Read card image 00001123 SETSP TEXTSP,NEXTSP ;Set up new line 00001124 STREAM XSP,TEXTSP,CARDTB,COMP3,COMP3 ;00001125 ; Analyze card type 00001126 RCALL ,NEWCRD,,<,,RTN3> ;Process card image 00001127 AEQLC LISTCL,0,,DIAGRN ;00001128 STPRNT IOKEY,OUTBLK,LNBFSP;Print out bypassed card 00001129 BRANCH DIAGRN ;00001130 ;_ 00001131 ;---------------------------------------------------------------------* 00001132 ; 00001133 ; Element Analysis 00001134 ; 00001135 ELEMNT:PROC , ;Element analysis procedure 00001136 RCALL ELEMND,UNOP,,RTN2 ;Get tree of unary operators 00001137 STREAM XSP,TEXTSP,ELEMTB,ELEICH,ELEILI ;00001138 ; Break out element 00001139 ELEMN9:SELBRA STYPE,<,ELEILT,ELEVBL,ELENST,ELEFNC,ELEFLT,ELEARY> ;00001140 ; Branch on element type 00001141 FSHRTN XSP,1 ;Delete initial quote 00001142 SHORTN XSP,1 ;Remove terminal quote 00001143 RCALL XPTR,GENVAR, ;00001144 ; Generate variable for literal 00001145 ELEMN5:RCALL ELEXND,BLOCK,CNDSIZ;Allocate block for tree node 00001146 PUTDC ELEXND,CODE,LITCL ;Insert literal function 00001147 RCALL ELEYND,BLOCK,CNDSIZ;Allocate block for tree node 00001148 PUTDC ELEYND,CODE,XPTR ;Insert literal value 00001149 ADDSON ELEXND,ELEYND ;Add node as son 00001150 ELEMN1:AEQLC ELEMND,0,ELEMN6 ;Check for empty tree 00001151 MOVD ZPTR,ELEXND ;Set up return 00001152 BRANCH ELEMRR ;Join return processing 00001153 ;_ 00001154 ELEMN6:ADDSON ELEMND,ELEXND ;Add as son of present tree 00001155 ELEMNR:MOVD ZPTR,ELEMND ;Move tree to return 00001156 ELEMRR:AEQLIC ZPTR,FATHER,0,,RTZPTR ;00001157 ; Is pointer at top of tree? 00001158 GETDC ZPTR,ZPTR,FATHER ;Move back to father 00001159 BRANCH ELEMRR ;Continue up tree 00001160 ;_ 00001161 ELEILT:SPCINT XPTR,XSP,ELEINT,ELEMN5 ;00001162 ; Convert string to integer 00001163 ;_ 00001164 ELEFLT:SPREAL XPTR,XSP,ELEDEC,ELEMN5 ;00001165 ; Convert string to real 00001166 ;_ 00001167 ELEVBL:RCALL XPTR,GENVAR, ;00001168 ; Generate variable 00001169 RCALL ELEXND,BLOCK,CNDSIZ;Allocate block for tree node 00001170 PUTDC ELEXND,CODE,XPTR ;Insert name 00001171 BRANCH ELEMN1 ;Join exit processing 00001172 ;_ 00001173 ELENST:PUSH ELEMND ;Save current tree 00001174 RCALL ELEXND,EXPR,,RTN1 ;Evaluate nested expression 00001175 POP ELEMND ;Restore tree 00001176 AEQLC BRTYPE,RPTYP,ELECMA,ELEMN1 ;00001177 ; Verify right parenthesis 00001178 ;_ 00001179 ELEFNC:SHORTN XSP,1 ;Delete open parenthesis 00001180 RCALL XPTR,GENVAR, ;00001181 ; Generate variable for function name 00001182 RCALL XCL,FINDEX, ;Find function descriptor 00001183 RCALL ELEXND,BLOCK,CNDSIZ;Allocate block for tree node 00001184 PUTDC ELEXND,CODE,XCL ;Insert function descriptor in node 00001185 AEQLC ELEMND,0,,ELEMN7 ;Is tree empty? 00001186 ADDSON ELEMND,ELEXND ;Add node as son to tree 00001187 ELEMN7:PUSH ELEXND ;Save current node 00001188 RCALL ELEXND,EXPR,,RTN1 ;Evaluate argument of function 00001189 POP ELEMND ;Resotre current node 00001190 ADDSON ELEMND,ELEXND ;Add argument as son 00001191 MOVD ELEMND,ELEXND ;Move to new node 00001192 ELEMN2:AEQLC BRTYPE,RPTYP,,ELEMN3 ;00001193 ; Check for left parenthesis 00001194 AEQLC BRTYPE,CMATYP,ELECMA ;00001195 ; Verify comma 00001196 PUSH ELEMND ;Save current node 00001197 RCALL ELEXND,EXPR,,RTN1 ;Evaluate next argument 00001198 POP ELEMND ;Restore current node 00001199 ADDSIB ELEMND,ELEXND ;Add argument as sibling 00001200 MOVD ELEMND,ELEXND ;Move to new node 00001201 BRANCH ELEMN2 ;Continue 00001202 ;_ 00001203 ELEMN3:GETDC ELEXND,ELEMND,FATHER ;00001204 ; Get father of current node 00001205 GETDC XCL,ELEXND,CODE ;Get function descriptor 00001206 GETDC YCL,XCL,0 ;Get procedure descriptor 00001207 TESTF YCL,FNC,,ELEMNR ;Check for fixed number requirement 00001208 SETAV XCL,XCL ;Get number of arguments given 00001209 SETAV YCL,YCL ;Get number of arguments expected 00001210 ELEMN4:ACOMP XCL,YCL,ELEMNR,ELEMNR ;00001211 ; Compare given and expected 00001212 RCALL ELEYND,BLOCK,CNDSIZ;Allocate block for tree node 00001213 PUTDC ELEYND,CODE,LITCL ;Insert literal function 00001214 RCALL ELEXND,BLOCK,CNDSIZ;Allocate block for tree node 00001215 PUTDC ELEXND,CODE,NULVCL ;Insert null string value 00001216 ADDSON ELEYND,ELEXND ;Add null as son of literal 00001217 ADDSIB ELEMND,ELEYND ;Add literal as extra argument 00001218 MOVD ELEMND,ELEYND ;Move to new node 00001219 INCRA XCL,1 ;Increment argument count 00001220 BRANCH ELEMN4 ;Continue 00001221 ;_ 00001222 ELEARY:SHORTN XSP,1 ;Remove left bracket 00001223 RCALL XPTR,GENVAR, ;00001224 ; Generate variable for array or table 00001225 RCALL ELEXND,BLOCK,CNDSIZ;Allocate block for tree node 00001226 PUTDC ELEXND,CODE,ITEMCL ;Insert ITEM function 00001227 AEQLC ELEMND,0,,ELEMN8 ;Is tree empty? 00001228 ADDSON ELEMND,ELEXND ;Add as son to tree 00001229 ELEMN8:MOVD ELEMND,ELEXND ;Move to new node 00001230 RCALL ELEXND,BLOCK,CNDSIZ;Allocate block for tree node 00001231 PUTDC ELEXND,CODE,XPTR ;Insert array or table name 00001232 ADDSON ELEMND,ELEXND ;Add as son to tree 00001233 MOVD ELEMND,ELEXND ;Move to new node 00001234 ELEAR1:PUSH ELEMND ;Save current node 00001235 RCALL ELEXND,EXPR,,RTN1 ;Evaluate argument 00001236 POP ELEMND ;Restore current node 00001237 ADDSIB ELEMND,ELEXND ;Add as sibling to tree 00001238 MOVD ELEMND,ELEXND ;Move to new node 00001239 AEQLC BRTYPE,RBTYP,,ELEMNR ;00001240 ; Check for right bracket 00001241 AEQLC BRTYPE,CMATYP,ELECMA,ELEAR1 ;00001242 ; Verify comma 00001243 ;_ 00001244 ELEICH:SETAC EMSGCL,ILCHAR ;'ILLEGAL CHARACTER IN ELEMENT' 00001245 BRANCH RTN1 ;Error return 00001246 ;_ 00001247 ELEILI:AEQLC STYPE,QLITYP,ELEMN9;Check cause of run out 00001248 SETAC EMSGCL,OPNLIT ;'UNCLOSED LITERAL' 00001249 BRANCH RTN1 ;Error return 00001250 ;_ 00001251 ELEINT:SETAC EMSGCL,ILLINT ;'ILLEGAL INTEGER' 00001252 BRANCH RTN1 ;Error return 00001253 ;_ 00001254 ELEDEC:SETAC EMSGCL,ILLDEC ;'ILLEGAL REAL' 00001255 BRANCH RTN1 ;Error return 00001256 ;_ 00001257 ELECMA:SETAC EMSGCL,ILLBRK ;'ILLEGAL BREAK CHARACTER' 00001258 BRANCH RTN1 ;Error return 00001259 ;_ 00001260 ;---------------------------------------------------------------------* 00001261 ; 00001262 ; Expression Analysis 00001263 ; 00001264 EXPR: PROC , ;Procedure to compile expression 00001265 RCALL EXELND,ELEMNT,, ;00001266 ; Compile element 00001267 SETAC EXPRND,0 ;Zero expression tree 00001268 BRANCH EXPR2 ;Join main processing 00001269 ;_ 00001270 EXPR1: PUSH EXPRND ;Save expression tree 00001271 RCALL EXELND,ELEMNT,, ;00001272 ; Compile element 00001273 POP EXPRND ;Restore expression tree 00001274 EXPR2: RCALL EXOPCL,BINOP,, ;00001275 ; Get binary operator 00001276 RCALL EXOPND,BLOCK,CNDSIZ;Allocate block for tree node 00001277 PUTDC EXOPND,CODE,EXOPCL ;Insert binary operator 00001278 AEQLC EXPRND,0,EXPR3 ;Check for empty tree 00001279 ADDSON EXOPND,EXELND ;Add node as son 00001280 MOVD EXPRND,EXELND ;Move to new node 00001281 BRANCH EXPR1 ;Continue processing 00001282 ;_ 00001283 EXPR3: GETDC EXOPCL,EXOPCL,2*DESCR ;00001284 ; Get precedence descriptor 00001285 SETAV EXOPCL,EXOPCL ;Get left precedence 00001286 GETDC EXEXND,EXPRND,FATHER ;00001287 ; Get father of node 00001288 GETDC XPTR,EXEXND,CODE ;Get function descriptor 00001289 GETDC XPTR,XPTR,2*DESCR ;Get precedence descriptor 00001290 ACOMP XPTR,EXOPCL,EXPR4 ;Compare precedences 00001291 ADDSIB EXPRND,EXOPND ;Add node as sibling 00001292 MOVD EXPRND,EXOPND ;Move to new node 00001293 ADDSON EXPRND,EXELND ;Put current node as son 00001294 MOVD EXPRND,EXELND ;Move to new node 00001295 BRANCH EXPR1 ;Continue processing 00001296 ;_ 00001297 EXPR4: ADDSIB EXPRND,EXELND ;Add current node as sibling 00001298 EXPR5: AEQLIC EXPRND,FATHER,0,,EXPR11 ;00001299 ; Check for root node 00001300 GETDC EXPRND,EXPRND,FATHER ;00001301 ; Get father node 00001302 AEQLIC EXPRND,FATHER,0,,EXPR11 ;00001303 ; Check for root node 00001304 GETDC EXEXND,EXPRND,FATHER ;00001305 ; Get father node 00001306 GETDC XPTR,EXEXND,CODE ;Get function descriptor 00001307 GETDC XPTR,XPTR,2*DESCR ;Get precedence descriptor 00001308 ACOMP XPTR,EXOPCL,EXPR5 ;Compare precedences 00001309 INSERT EXPRND,EXOPND ;Insert node above 00001310 BRANCH EXPR1 ;Continue processing 00001311 ;_ 00001312 EXPR7: AEQLC EXPRND,0,EXPR10 ;Check for empty tree 00001313 MOVD XPTR,EXELND ;Set up for return 00001314 BRANCH EXPR9 ;Join end processing 00001315 ;_ 00001316 EXPR10:ADDSIB EXPRND,EXELND ;Add node as sibling 00001317 MOVD XPTR,EXPRND ;Set up for return 00001318 EXPR9: AEQLIC XPTR,FATHER,0,,RTXNAM ;00001319 ; Check for root node 00001320 GETDC XPTR,XPTR,FATHER ;Go back to father 00001321 BRANCH EXPR9 ;Continue up tree 00001322 ;_ 00001323 EXPR11:ADDSON EXOPND,EXPRND ;Add node as son 00001324 BRANCH EXPR1 ;Continue processing 00001325 ;_ 00001326 EXPNUL:RCALL EXPRND,BLOCK,CNDSIZ;Allocate block for tree node 00001327 PUTDC EXPRND,CODE,LITCL ;Insert literal function 00001328 RCALL EXEXND,BLOCK,CNDSIZ;Allocate block for tree node 00001329 PUTDC EXEXND,CODE,NULVCL ;Insert null string as value 00001330 ADDSON EXPRND,EXEXND ;Add node as son 00001331 MOVD XPTR,EXPRND ;Set up for return 00001332 BRANCH RTXNAM ;00001333 ;_ 00001334 EXPERR:SETAC EMSGCL,ILLEOS ;'ILLEGAL END OF STATEMENT' 00001335 BRANCH RTN1 ;Take error return 00001336 ;_ 00001337 ;---------------------------------------------------------------------* 00001338 ; 00001339 ; Location of Next Nonblank Character 00001340 ; 00001341 FORWRD:PROC , ;Procedure to get to next character 00001342 STREAM XSP,TEXTSP,FRWDTB,COMP3,FORRUN ;00001343 ; Break for next nonblank 00001344 FORJRN:MOVD BRTYPE,STYPE ;Set up break type 00001345 BRANCH RTN2 ;Return 00001346 ;_ 00001347 FORRUN:AEQLC UNIT,0,,FOREOS ;Check for input stream 00001348 AEQLC LISTCL,0,,FORRUR ;Check listing switch 00001349 STPRNT IOKEY,OUTBLK,LNBFSP;Print card image 00001350 FORRUR:STREAD INBFSP,UNIT,FORRUR,COMP5 ;00001351 ; Read new card iamge 00001352 SETSP TEXTSP,NEXTSP ;Set up new line 00001353 STREAM XSP,TEXTSP,CARDTB,COMP3,COMP3 ;00001354 ; Determine card type 00001355 RCALL ,NEWCRD,, ;00001356 ; Process new card 00001357 FOREOS:MOVD BRTYPE,EOSCL ;Set up end-of-card 00001358 BRANCH RTN2 ;Return 00001359 ;_ 00001360 FORBLK:PROC FORWRD ;Procedure to get to nonblank 00001361 STREAM XSP,TEXTSP,IBLKTB,RTN1,FORRUN,FORJRN ;00001362 ; Break out nonblank from blank 00001363 ;_ 00001364 ;---------------------------------------------------------------------* 00001365 ; 00001366 ; Card Image Processing 00001367 ; 00001368 NEWCRD:PROC , ;Process new card image 00001369 SELBRA STYPE,<,CMTCRD,CTLCRD,CNTCRD> ;00001370 ; Branch on card type 00001371 AEQLC LISTCL,0,,RTN3 ;Return if listing is off 00001372 MOVD XCL,CSTNCL ;Copy of statement number 00001373 INCRA XCL,1 ;Increment number 00001374 INTSPC TSP,XCL ;Convert it to STRING 00001375 AEQLC LLIST,0,CARDL ;Check for left listing 00001376 SETLC RNOSP,0 ;Clear right specifier 00001377 APDSP RNOSP,TSP ;Set to statement number 00001378 BRANCH RTN3 ;00001379 ;_ 00001380 CARDL: SETLC LNOSP,0 ;Clear left specifier 00001381 APDSP LNOSP,TSP ;Set to statement number 00001382 BRANCH RTN3 ;00001383 ;_ 00001384 CMTCRD:AEQLC LISTCL,0,,RTN1 ;Return if listing is off 00001385 CMTCLR:SETLC LNOSP,0 ;Clear left specifier 00001386 SETLC RNOSP,0 ;Clear right specifier 00001387 APDSP LNOSP,BLNSP ;Blank left specifier 00001388 APDSP RNOSP,BLNSP ;Blank right specifier 00001389 BRANCH RTN1 ;00001390 ;_ 00001391 CNTCRD:FSHRTN TEXTSP,1 ;Remove continue character 00001392 AEQLC LISTCL,0,,RTN2 ;Return if listing is off 00001393 INTSPC TSP,CSTNCL ;Get specifier for number 00001394 AEQLC LLIST,0,CARDLL ;Check for left listing 00001395 SETLC RNOSP,0 ;Clear right specifier 00001396 APDSP RNOSP,TSP ;Set to statement number 00001397 BRANCH RTN2 ;00001398 ;_ 00001399 CARDLL:SETLC LNOSP,0 ;Clear left specifier 00001400 APDSP LNOSP,TSP ;Set to statement number 00001401 BRANCH RTN2 ;00001402 ;_ 00001403 CTLCRD:FSHRTN TEXTSP,1 ;Delete control character 00001404 STREAM XSP,TEXTSP,FRWDTB,COMP3,CMTCRD ;00001405 ; Get to next nonblank character 00001406 AEQLC STYPE,NBTYP,CMTCRD ;Verify nonbreak 00001407 STREAM XSP,TEXTSP,LBLXTB,CMTCLR,CMTCLR ;00001408 ; Break out command 00001409 LEXCMP XSP,UNLSP,CTLCR1,,CTLCR1 ;00001410 ; Is it UNLIST? 00001411 SETAC LISTCL,0 ;Zero listing switch 00001412 BRANCH RTN1 ;Return 00001413 ;_ 00001414 CTLCR1:LEXCMP XSP,LISTSP,CTLCR3,,CTLCR3 ;00001415 ; Is it LIST? 00001416 SETAC LISTCL,1 ;Turn on listing 00001417 STREAM XSP,TEXTSP,FRWDTB,COMP3,CMTCLR ;00001418 ; Get to next nonblank character 00001419 AEQLC STYPE,NBTYP,CMTCLR ;Verify nonbreak 00001420 STREAM XSP,TEXTSP,LBLXTB,CMTCLR,CMTCLR ;00001421 ; Get type of listing 00001422 LEXCMP XSP,LEFTSP,CTLCR2,,CTLCR2 ;00001423 ; Is it LEFT? 00001424 SETAC LLIST,1 ;Set left listing switch 00001425 BRANCH CMTCLR ;Join terminal processing 00001426 ;_ 00001427 CTLCR2:SETAC LLIST,0 ;Zero left listing as default 00001428 BRANCH CMTCLR ;Join terminal processing 00001429 ;_ 00001430 CTLCR3:LEXCMP XSP,EJCTSP,CMTCLR,,CMTCLR ;00001431 ; Is it EJECT? 00001432 AEQLC LISTCL,0,,CMTCLR ;Skip eject if not listing 00001433 OUTPUT OUTPUT,EJECTF ;Eject page 00001434 BRANCH CMTCLR ;Join terminal processing 00001435 ;_ 00001436 ;---------------------------------------------------------------------* 00001437 ; 00001438 ; Publication of Code Trees 00001439 ; 00001440 TREPUB:PROC , ;Publish code tree 00001441 POP YPTR ;Restore root node 00001442 TREPU1:GETDC XPTR,YPTR,CODE ;Get code descriptor 00001443 INCRA CMOFCL,DESCR ;Increment offset 00001444 PUTD CMBSCL,CMOFCL,XPTR ;Insert code descriptor 00001445 SUM ZPTR,CMBSCL,CMOFCL ;Compute total position 00001446 ACOMP ZPTR,OCLIM,TREPU5 ;Check against limit 00001447 TREPU4:AEQLIC YPTR,LSON,0,,TREPU2;Is there a left son? 00001448 GETDC YPTR,YPTR,LSON ;Get left son 00001449 BRANCH TREPU1 ;Continue 00001450 ;_ 00001451 TREPU2:AEQLIC YPTR,RSIB,0,,TREPU3;Is there a right sibling? 00001452 GETDC YPTR,YPTR,RSIB ;Get right sibling 00001453 BRANCH TREPU1 ;Continue 00001454 ;_ 00001455 TREPU3:AEQLIC YPTR,FATHER,0,,RTN1;Is there a father? 00001456 GETDC YPTR,YPTR,FATHER ;Get father 00001457 BRANCH TREPU2 ;Continue 00001458 ;_ 00001459 TREPU5:SUM ZPTR,CMOFCL,CODELT ;Compute additional to get 00001460 SETVC ZPTR,C ;Insert CODE data type 00001461 RCALL XCL,BLOCK,ZPTR ;Allocate new code block 00001462 AEQLC LPTR,0,,TREPU6 ;Is there a last label? 00001463 PUTDC LPTR,ATTRIB,XCL ;Insert new code position 00001464 TREPU6:MOVBLK XCL,CMBSCL,CMOFCL ;Move old code 00001465 PUTDC CMBSCL,DESCR,GOTGCL;Insert direct goto 00001466 PUTDC CMBSCL,2*DESCR,LIT1CL ;E3.7.1 ; Insert literal function 00001468 PUTDC CMBSCL,3*DESCR,XCL ;Insert pointer to new code 00001469 INCRA CMBSCL,3*DESCR ;Update end pointer 00001470 RCALL ,SPLIT, ;Split off old portion 00001471 MOVD CMBSCL,XCL ;Set up new compiler base pointer 00001472 SUM OCLIM,CMBSCL,ZPTR ;Compute new limit 00001473 DECRA OCLIM,5*DESCR ;Leave safety factor 00001474 BRANCH TREPU4 ;Rejoin processing 00001475 ;_ 00001476 ;---------------------------------------------------------------------* 00001477 ; 00001478 ; Unary Operator Analysis 00001479 ; 00001480 UNOP: PROC , ;Unary operator analysis 00001481 RCALL ,FORWRD,,COMP3 ;Get to next nonblank character 00001482 SETAC XPTR,0 ;Zero code tree 00001483 AEQLC BRTYPE,NBTYP,RTN1 ;Verify nonbreak 00001484 UNOPA: STREAM XSP,TEXTSP,UNOPTB,RTXNAM,RTN1 ;E3.4.3 ; Break out unary operator 00001486 RCALL YPTR,BLOCK,CNDSIZ ;Allocate block for tree node 00001487 PUTDC YPTR,CODE,STYPE ;Insert function descriptor 00001488 AEQLC XPTR,0,,UNOPB ;Is tree empty 00001489 ADDSON XPTR,YPTR ;Add new node as son 00001490 UNOPB: MOVD XPTR,YPTR ;Move to new node 00001491 BRANCH UNOPA ;Continue 00001492 ;_ 00001493 ;---------------------------------------------------------------------* 00001494 .PAGE .SBTTL 'Interpreter Executive and Control Procedures' ;00001495 .PSECT SNOBOL4_INTERPRETER,SHR,LONG ; 00001496 ; Code Basing 00001497 ; 00001498 BASE: PROC , ;Interpreter code basing procedure 00001499 SUM OCBSCL,OCBSCL,OCICL;Add offset to base 00001500 SETAC OCICL,0 ;Zero offset 00001501 BRANCH RTNUL3 ;00001502 ;_ 00001503 ;---------------------------------------------------------------------* 00001504 ; 00001505 ; Direct Goto 00001506 ; 00001507 GOTG: PROC , ;: 00001508 RCALL OCBSCL,ARGVAL,,INTR5 ;00001509 ; Get code pointer 00001510 VEQLC OCBSCL,C,INTR4 ;Must have CODE data type 00001511 SETAC OCICL,0 ;Zero offset 00001512 BRANCH RTNUL3 ;00001513 ;_ 00001514 ;---------------------------------------------------------------------* 00001515 ; 00001516 ; Label Goto 00001517 ; 00001518 GOTL: PROC , ;:(X) 00001519 INCRA OCICL,DESCR ;Increment offset 00001520 GETD XPTR,OCBSCL,OCICL ;Get object code descriptor 00001521 TESTF XPTR,FNC,,GOTLC ;Test for function 00001522 GOTLV: ACOMPC TRAPCL,0,,GOTLV1,GOTLV1 ;00001523 ; Check &TRACE 00001524 LOCAPT ATPTR,TLABL,XPTR,GOTLV1 ;00001525 ; Look for LABEL trace 00001526 PUSH XPTR ;Save variable 00001527 RCALL ,TRPHND,ATPTR ;E3.3.1 ; Perform trace 00001529 POP XPTR ;Restore variable 00001530 GOTLV1:DEQL XPTR,RETCL,GOTL1 ;Compare with RETURN 00001531 RRTURN ,6 ;Return by value 00001532 ;_ 00001533 GOTL1: DEQL XPTR,FRETCL,GOTL2 ;Compare with FRETURN 00001534 RRTURN ,4 ;Fail 00001535 ;_ 00001536 GOTL2: DEQL XPTR,NRETCL,GOTL3 ;Compare with NRETURN 00001537 RRTURN ,5 ;Return by name 00001538 ;_ 00001539 GOTL3: GETDC OCBSCL,XPTR,ATTRIB ;Get object code base 00001540 AEQLC OCBSCL,0,,INTR4 ;Must not be zero 00001541 SETAC OCICL,0 ;Zero offset 00001542 BRANCH RTNUL3 ;Return 00001543 ;_ 00001544 GOTLC: RCALL XPTR,INVOKE,XPTR, ;E3.10.3 ; Evaluate goto 00001546 VEQLC XPTR,S,INTR4,GOTLV ;Variable must be STRING 00001547 ;_ 00001548 ;---------------------------------------------------------------------* 00001549 ; 00001550 ; Internal Goto 00001551 ; 00001552 GOTO: PROC , ;Interpreter goto procedure 00001553 INCRA OCICL,DESCR ;Increment offset 00001554 GETD OCICL,OCBSCL,OCICL ;Get offset 00001555 BRANCH RTNUL3 ;Return 00001556 ;_ 00001557 ;---------------------------------------------------------------------* 00001558 ; 00001559 ; Statement Initialization 00001560 ; 00001561 INIT: PROC , ;Statement initialization procedure 00001562 MOVD LSTNCL,STNOCL ;Update &LASTNO 00001563 INCRA OCICL,DESCR ;Increment offset 00001564 GETD XCL,OCBSCL,OCICL ;Get statement data 00001565 MOVA STNOCL,XCL ;Update &STNO 00001566 SETAV FRTNCL,XCL ;Set up failure offset 00001567 ACOMP EXNOCL,EXLMCL,EXEX,EXEX ;00001568 ; Check &STLIMIT 00001569 INCRA EXNOCL,1 ;Increment &STCOUNT 00001570 ACOMPC TRAPCL,0,,RTNUL3,RTNUL3 ;00001571 ; Check &TRACE 00001572 LOCAPT ATPTR,TKEYL,STCTKY,RTNUL3 ;00001573 RCALL ,TRPHND,ATPTR ;E3.3.1 ; Perform trace 00001575 BRANCH RTNUL3 ;00001576 ;_ 00001577 ;---------------------------------------------------------------------* 00001578 ; 00001579 ; Basic Interpreter Procedure 00001580 ; 00001581 INTERP:PROC , ;Interpreter core procedure 00001582 INCRA OCICL,DESCR ;Increment offset 00001583 GETD XPTR,OCBSCL,OCICL ;Get object code descriptor 00001584 TESTF XPTR,FNC,INTERP ;Test for function 00001585 RCALL XPTR,INVOKE,,<,INTERP,INTERP,RTN1,RTN2,RTN3> ;00001586 MOVD OCICL,FRTNCL ;Set offset for failure 00001587 INCRA FALCL,1 ;Increment &STFCOUNT 00001588 ACOMPC TRAPCL,0,,INTERP,INTERP ;00001589 ; Check &TRACE 00001590 LOCAPT ATPTR,TKEYL,FALKY,INTERP ;00001591 RCALL ,TRPHND,ATPTR ;E3.3.1 ; Perform trace 00001593 BRANCH INTERP ;00001594 ;_ 00001595 ;---------------------------------------------------------------------* 00001596 ; 00001597 ; Procedure Invocation 00001598 ; 00001599 INVOKE:PROC , ;Invokation procedure 00001600 POP INCL ;Get function index 00001601 GETDC XPTR,INCL,0 ;Get procedure descriptor 00001602 VEQL INCL,XPTR,INVK2 ;Check argument counts 00001603 INVK1: BRANIC INCL,0 ;If equal, branch indirect 00001604 ;_ 00001605 INVK2: TESTF XPTR,FNC,ARGNER,INVK1 ;00001606 ; Check for variable argument number 00001607 ;_ 00001608 ;---------------------------------------------------------------------* 00001609 .PAGE .SBTTL 'Argument Evaluation Procedures' ;00001610 .PSECT SNOBOL4_ARG_EVAL,SHR,LONG ; 00001611 ; Argument Evaluation 00001612 ; 00001613 ARGVAL:PROC , ;Procedure to evaluate argument 00001614 INCRA OCICL,DESCR ;Increment interpreter offset 00001615 GETD XPTR,OCBSCL,OCICL ;Get argument 00001616 TESTF XPTR,FNC,,ARGVC ;Test for function descriptor 00001617 ARGV1: AEQLC INSW,0,,ARGV2 ;Check &INPUT 00001618 LOCAPV ZPTR,INATL,XPTR,ARGV2 ;00001619 ; Look for input association 00001620 GETDC ZPTR,ZPTR,DESCR ;Get input descriptor 00001621 RCALL XPTR,PUTIN,, ;00001622 ;_ 00001623 ARGVC: RCALL XPTR,INVOKE,, ;00001624 ;_ 00001625 ARGV2: GETDC XPTR,XPTR,DESCR ;Get value from name 00001626 BRANCH RTXNAM ;00001627 ;_ 00001628 ;---------------------------------------------------------------------* 00001629 ; 00001630 ; Evaluation of Unevaluated Expressions 00001631 ; 00001632 EXPVAL:PROC , ;Procedure to evaluate expression 00001633 SETAC SCL,1 ;Note procedure entrance 00001634 EXPVJN:POP XPTR ;Restore pointer to object code 00001635 EXPVJ2:PUSH ;00001636 PUSH ;00001637 ; Save system state descriptors 00001638 SPUSH ;00001639 ; Save system state specifiers 00001640 MOVD OCBSCL,XPTR ;Set up new code base 00001641 SETAC OCICL,DESCR ;Initialize offset 00001642 MOVD PDLHED,PDLPTR ;Set up new history list header 00001643 MOVD NHEDCL,NAMICL ;Set up new name list header 00001644 GETD XPTR,OCBSCL,OCICL ;Get object code descriptor 00001645 TESTF XPTR,FNC,,EXPVC ;Check for function 00001646 EXPV11:AEQLC SCL,0,,EXPV6 ;Check procedure entry 00001647 AEQLC INSW,0,,EXPV4 ;Check &INPUT 00001648 LOCAPV ZPTR,INATL,XPTR,EXPV4 ;00001649 ; Look for input association 00001650 GETDC ZPTR,ZPTR,DESCR ;Get input association 00001651 RCALL XPTR,PUTIN,, ;00001652 ; Perform input 00001653 ;_ 00001654 EXPV4: GETDC XPTR,XPTR,DESCR ;Get value 00001655 EXPV6: SETAC SCL,2 ;Set up exit 00001656 BRANCH EXPV7 ;Join processing 00001657 ;_ 00001658 EXPV9: POP SCL ;Popoff switch 00001659 EXPV1: SETAC SCL,1 ;Set new exit switch 00001660 EXPV7: SPOP ;00001661 ; Restore system specifiers 00001662 POP ;00001663 POP ;00001664 ; Restore system descriptors 00001665 SELBRA SCL, ;00001666 ; Select exit 00001667 ;_ 00001668 EXPVC: PUSH SCL ;Save entrance indicator 00001669 RCALL XPTR,INVOKE,XPTR, ;00001670 ; Evaluate function 00001671 POP SCL ;Restore entrance indicator 00001672 AEQLC SCL,0,EXPV6 ;Check entry indicator 00001673 SETAC SCL,3 ;Set exit switch 00001674 MOVD ZPTR,XPTR ;Set up value 00001675 BRANCH EXPV7 ;Join end processing 00001676 ;_ 00001677 EXPV5: POP SCL ;Restore entry indicator 00001678 BRANCH EXPV11 ;Join processing with name 00001679 ;_ 00001680 EXPEVL:PROC EXPVAL ;Procedure to get expression value 00001681 SETAC SCL,0 ;Set entry indicator 00001682 BRANCH EXPVJN ;Join processing 00001683 ;_ 00001684 EVAL: PROC EXPVAL ;EVAL(X) 00001685 RCALL XPTR,ARGVAL,,FAIL ;Get argument 00001686 VEQLC XPTR,E,,EVAL1 ;Is it EXPRESSION? 00001687 VEQLC XPTR,I,,RTXPTR ;INTEGER is idempotent 00001688 VEQLC XPTR,R,,RTXPTR ;REAL is idempotent 00001689 VEQLC XPTR,S,INTR1 ;Is it STRING? 00001690 LOCSP XSP,XPTR ;Get specifier 00001691 LEQLC XSP,0,,RTXPTR ;E3.1.4 SPCINT XPTR,XSP,,RTXPTR ;Convert to INTEGER 00001692 SPREAL XPTR,XSP,,RTXPTR ;Convert to REAL 00001693 MOVD ZPTR,XPTR ;Set up to convert to EXPRESSION 00001694 RCALL XPTR,CONVE,, ;00001695 ; Convert to EXPRESSION 00001696 EVAL1: SETAC SCL,0 ;Set up entry indicator 00001697 BRANCH EXPVJ2 ;Join processing 00001698 ;_ 00001699 ;---------------------------------------------------------------------* 00001700 ; 00001701 ; Evaluation of Integer Argument 00001702 ; 00001703 INTVAL:PROC , ;Integer argument procedure 00001704 INCRA OCICL,DESCR ;Increment offset 00001705 GETD XPTR,OCBSCL,OCICL ;Get object code descriptor 00001706 TESTF XPTR,FNC,,INTVC ;Check for function 00001707 INTV1: AEQLC INSW,0,,INTV3 ;Check &INPUT 00001708 LOCAPV ZPTR,INATL,XPTR,INTV3 ;00001709 ; Look for input association 00001710 GETDC ZPTR,ZPTR,DESCR ;Get association 00001711 RCALL XPTR,PUTIN,,FAIL ;00001712 ; Perform input 00001713 INTV: LOCSP XSP,XPTR ;Get specifier for string 00001714 SPCINT XPTR,XSP,INTR1,RTXNAM ;00001715 ; Convert to integer 00001716 ;_ 00001717 INTV3: GETDC XPTR,XPTR,DESCR ;Get value 00001718 INTV2: VEQLC XPTR,I,,RTXNAM ;INTEGER desired 00001719 VEQLC XPTR,S,INTR1,INTV ;STRING must be converted 00001720 ;_ 00001721 INTVC: RCALL XPTR,INVOKE,, ;00001722 ;_ 00001723 ;---------------------------------------------------------------------* 00001724 ; 00001725 ; Evaluation of Argument as Pattern 00001726 ; 00001727 PATVAL:PROC , ;Evaluate argument as pattern 00001728 INCRA OCICL,DESCR ;Increment offset 00001729 GETD XPTR,OCBSCL,OCICL ;Get object code descriptor 00001730 TESTF XPTR,FNC,,PATVC ;Check for function descriptor 00001731 PATV1: AEQLC INSW,0,,PATV2 ;Check &INPUT 00001732 LOCAPV ZPTR,INATL,XPTR,PATV2 ;00001733 ; Look for input association 00001734 GETDC ZPTR,ZPTR,DESCR ;Get association 00001735 RCALL XPTR,PUTIN,, ;00001736 ; Perform input 00001737 ;_ 00001738 PATVC: RCALL XPTR,INVOKE,, ;00001739 ; Evaluate argument 00001740 ;_ 00001741 PATV2: GETDC XPTR,XPTR,DESCR ;Get value 00001742 PATV3: VEQLC XPTR,P,,RTXNAM ;Is it PATTERN? 00001743 VEQLC XPTR,S,,RTXNAM ;Is it STRING? 00001744 VEQLC XPTR,I,,GENVIX ;Is it INTEGER? 00001745 VEQLC XPTR,R,,PATVR ;Is it REAL? 00001746 VEQLC XPTR,E,INTR1 ;Is it EXPRESSION? 00001747 RCALL TPTR,BLOCK,STARSZ ;Allocate block for pattern 00001748 MOVBLK TPTR,STRPAT,STARSZ ;Copy pattern for expression 00001749 PUTDC TPTR,4*DESCR,XPTR ;Insert expression 00001750 MOVD XPTR,TPTR ;Set up value 00001751 BRANCH RTXNAM ;Return 00001752 ;_ 00001753 PATVR: REALST XSP,XPTR ;Convert REAL to STRING 00001754 RCALL XPTR,GENVAR,XSPPTR,RTXNAM ;00001755 ; Generate variable 00001756 ;_ 00001757 ;---------------------------------------------------------------------* 00001758 ; 00001759 ; Evaluation of Argument as String 00001760 ; 00001761 VARVAL:PROC , ;Evaluate argument as string 00001762 INCRA OCICL,DESCR ;Increment offset 00001763 GETD XPTR,OCBSCL,OCICL ;Get object code descriptor 00001764 TESTF XPTR,FNC,,VARVC ;Check for function 00001765 VARV1: AEQLC INSW,0,,VARV4 ;Check &INPUT 00001766 LOCAPV ZPTR,INATL,XPTR,VARV4 ;00001767 ; Look for input association 00001768 GETDC ZPTR,ZPTR,DESCR ;Get input association 00001769 RCALL XPTR,PUTIN,, ;00001770 ; Perform input 00001771 ;_ 00001772 VARV4: GETDC XPTR,XPTR,DESCR ;Get value 00001773 VARV2: VEQLC XPTR,S,,RTXNAM ;Is it STRING? 00001774 VEQLC XPTR,I,INTR1,GENVIX;Convert INTEGER to STRING 00001775 ;_ 00001776 VARVC: RCALL XPTR,INVOKE,, ;00001777 ; Evaluate function 00001778 ;_ 00001779 ;---------------------------------------------------------------------* 00001780 ; 00001781 ; Evaluation of Argument Pair 00001782 ; 00001783 XYARGS:PROC , ;Procedure to evaluate argument pair 00001784 SETAC SCL,0 ;Note first argument 00001785 XYN: INCRA OCICL,DESCR ;Increment offset 00001786 GETD YPTR,OCBSCL,OCICL ;Get object code descriptor 00001787 TESTF YPTR,FNC,,XYC ;Check for function 00001788 XY1: AEQLC INSW,0,,XY2 ;Check &INPUT 00001789 LOCAPV ZPTR,INATL,YPTR,XY2;Look for input association 00001790 GETDC ZPTR,ZPTR,DESCR ;Get input association 00001791 RCALL YPTR,PUTIN,,FAIL ;00001792 ; Perform input 00001793 XY3: AEQLC SCL,0,RTN2 ;Check for completion 00001794 SETAC SCL,1 ;Note seconf argument 00001795 MOVD XPTR,YPTR ;Set up first argument 00001796 BRANCH XYN ;Go around again 00001797 ;_ 00001798 XY2: GETDC YPTR,YPTR,DESCR ;Get value 00001799 BRANCH XY3 ;Continue 00001800 ;_ 00001801 XYC: PUSH ;Save indicator and argument 00001802 RCALL YPTR,INVOKE,, ;00001803 ; Evaluate function 00001804 POP ;Restore indicator and argument 00001805 BRANCH XY3 ;Join processing 00001806 ;_ 00001807 XY4: POP ;Restore indicator and argument 00001808 BRANCH XY1 ;Join processing 00001809 ;_ 00001810 ;---------------------------------------------------------------------* 00001811 .PAGE .SBTTL 'Arithmetic Operations, Predicates, and Functions' ;00001812 .PSECT SNOBOL4_ARITHMETIC,SHR,LONG ADD: PROC , ;X + Y 00001813 SETAC SCL,1 ;00001814 BRANCH ARITH ;00001815 ;_ 00001816 DIV: PROC ADD ;X / Y 00001817 SETAC SCL,2 ;00001818 BRANCH ARITH ;00001819 ;_ 00001820 EXP: PROC ADD ;X ** Y and X ^ Y 00001821 SETAC SCL,3 ;00001822 BRANCH ARITH ;00001823 ;_ 00001824 MPY: PROC ADD ;X * Y 00001825 SETAC SCL,4 ;00001826 BRANCH ARITH ;00001827 ;_ 00001828 SUB: PROC ADD ;X - Y 00001829 SETAC SCL,5 ;00001830 BRANCH ARITH ;00001831 ;_ 00001832 EQ: PROC ADD ;EQ(X,Y) 00001833 SETAC SCL,6 ;00001834 BRANCH ARITH ;00001835 ;_ 00001836 GE: PROC ADD ;GE(X,Y) 00001837 SETAC SCL,7 ;00001838 BRANCH ARITH ;00001839 ;_ 00001840 GT: PROC ADD ;GT(X,Y) 00001841 SETAC SCL,8 ;00001842 BRANCH ARITH ;00001843 ;_ 00001844 LE: PROC ADD ;LE(X,Y) 00001845 SETAC SCL,9 ;00001846 BRANCH ARITH ;00001847 ;_ 00001848 LT: PROC ADD ;LT(X,Y) 00001849 SETAC SCL,10 ;00001850 BRANCH ARITH ;00001851 ;_ 00001852 NE: PROC ADD ;NE(X,Y) 00001853 SETAC SCL,11 ;00001854 BRANCH ARITH ;00001855 ;_ 00001856 REMDR: PROC ADD ;REMDR(X,Y) 00001857 SETAC SCL,12 ;00001858 BRANCH ARITH ;00001859 ;_ 00001860 ARITH: PUSH SCL ;Save procedure switch 00001861 RCALL ,XYARGS,,FAIL ;Evaluate arguments 00001862 POP SCL ;Restore procedure switch 00001863 SETAV DTCL,XPTR ;Set up data type pair 00001864 MOVV DTCL,YPTR ;00001865 DEQL DTCL,IIDTP,,ARTHII ;INTEGER-INTEGER 00001866 DEQL DTCL,IVDTP,,ARTHIV ;INTEGER-STRING 00001867 DEQL DTCL,VIDTP,,ARTHVI ;STRING-INTEGER 00001868 DEQL DTCL,VVDTP,,ARTHVV ;STRING-STRING 00001869 DEQL DTCL,RRDTP,,ARTHRR ;REAL-REAL 00001870 DEQL DTCL,IRDTP,,ARTHIR ;INTEGER-REAL 00001871 DEQL DTCL,RIDTP,,ARTHRI ;REAL-INTEGER 00001872 DEQL DTCL,VRDTP,,ARTHVR ;STRING-REAL 00001873 DEQL DTCL,RVDTP,INTR1,ARTHRV ;00001874 ; REAL-STRING 00001875 ;_ 00001876 ARTHII:SELBRA SCL, ;00001877 ;_ 00001878 ARTHVI:LOCSP XSP,XPTR ;Get specifier 00001879 SPCINT XPTR,XSP,,ARTHII ;Convert string to integer 00001880 SPREAL XPTR,XSP,INTR1,ARTHRI ;00001881 ; Convert to real if possible 00001882 ;_ 00001883 ARTHIV:LOCSP YSP,YPTR ;Get specifier 00001884 SPCINT YPTR,YSP,,ARTHII ;Convert string to integer 00001885 SPREAL YPTR,YSP,INTR1,ARTHIR ;00001886 ; Convert to real if possible 00001887 ;_ 00001888 ARTHVV:LOCSP XSP,XPTR ;Get specifier 00001889 SPCINT XPTR,XSP,,ARTHIV ;Convert string to integer 00001890 SPREAL XPTR,XSP,INTR1,ARTHRV ;00001891 ; Convert to real if possible 00001892 ;_ 00001893 ARTHRR:SELBRA SCL, ;00001894 ;_ 00001895 ARTHIR:INTRL XPTR,XPTR ;Convert integer to real 00001896 BRANCH ARTHRR ;00001897 ;_ 00001898 ARTHRI:INTRL YPTR,YPTR ;Convert integer to real 00001899 BRANCH ARTHRR ;00001900 ;_ 00001901 ARTHVR:LOCSP XSP,XPTR ;Get spedifier 00001902 SPCINT XPTR,XSP,,ARTHIR ;Convert string to integer 00001903 SPREAL XPTR,XSP,INTR1,ARTHRR ;00001904 ; Convert to real if possible 00001905 ;_ 00001906 ARTHRV:LOCSP YSP,YPTR ;00001907 SPCINT YPTR,YSP,,ARTHRI ;Convert string to integer 00001908 SPREAL YPTR,YSP,INTR1,ARTHRR ;00001909 ; Convert to real if possible 00001910 ;_ 00001911 AD: SUM ZPTR,XPTR,YPTR,AERROR,ARTN ;00001912 ;_ 00001913 ;$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ; 'DV' IS A RESERVED WORD IN VAX MACRO ???!?!?@@*^#@# DVQ: DIVIDE ZPTR,XPTR,YPTR,AERROR,ARTN ;00001914 ;$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ;_ 00001915 EX: EXPINT ZPTR,XPTR,YPTR,AERROR,ARTN ;00001916 ;_ 00001917 MP: MULT ZPTR,XPTR,YPTR,AERROR,ARTN ;00001918 ;_ 00001919 SB: SUBTRT ZPTR,XPTR,YPTR,AERROR,ARTN ;00001920 ;_ 00001921 CEQ: AEQL XPTR,YPTR,FAIL,RETNUL ;00001922 ;_ 00001923 CGE: ACOMP XPTR,YPTR,RETNUL,RETNUL,FAIL ;00001924 ;_ 00001925 CGT: ACOMP XPTR,YPTR,RETNUL,FAIL,FAIL ;00001926 ;_ 00001927 CLE: ACOMP XPTR,YPTR,FAIL,RETNUL,RETNUL ;00001928 ;_ 00001929 CLT: ACOMP XPTR,YPTR,FAIL,FAIL,RETNUL ;00001930 ;_ 00001931 CNE: AEQL XPTR,YPTR,RETNUL,FAIL ;00001932 ;_ 00001933 AR: ADREAL ZPTR,XPTR,YPTR,AERROR,ARTN ;00001934 ;_ 00001935 DR: DVREAL ZPTR,XPTR,YPTR,AERROR,ARTN ;00001936 ;_ 00001937 EXR: EXREAL ZPTR,XPTR,YPTR,AERROR,ARTN ;00001938 ;_ 00001939 MR: MPREAL ZPTR,XPTR,YPTR,AERROR,ARTN ;00001940 ;_ 00001941 SR: SBREAL ZPTR,XPTR,YPTR,AERROR,ARTN ;00001942 ;_ 00001943 REQ: RCOMP XPTR,YPTR,FAIL,RETNUL,FAIL ;00001944 ;_ 00001945 RGE: RCOMP XPTR,YPTR,RETNUL,RETNUL,FAIL ;00001946 ;_ 00001947 RGT: RCOMP XPTR,YPTR,RETNUL,FAIL,FAIL ;00001948 ;_ 00001949 RLE: RCOMP XPTR,YPTR,FAIL,RETNUL,RETNUL ;00001950 ;_ 00001951 RLT: RCOMP XPTR,YPTR,FAIL,FAIL,RETNUL ;00001952 ;_ 00001953 RNE: RCOMP XPTR,YPTR,RETNUL,FAIL,RETNUL ;00001954 ;_ 00001955 RM: DIVIDE ZPTR,XPTR,YPTR,AERROR ;00001956 ; First divide 00001957 MULT WPTR,ZPTR,YPTR ;Multiply truncated part 00001958 SUBTRT ZPTR,XPTR,WPTR ;Get difference 00001959 BRANCH ARTN ;00001960 ;_ 00001961 ;---------------------------------------------------------------------* 00001962 ; 00001963 ; INTEGER(X) 00001964 ; 00001965 INTGER:PROC , ;INTEGER(X) 00001966 RCALL XPTR,ARGVAL,,FAIL ;Get argument 00001967 VEQLC XPTR,I,,RETNUL ;INTEGER succeeds 00001968 VEQLC XPTR,S,FAIL ;STRING must be checked 00001969 LOCSP XSP,XPTR ;Get specifier 00001970 SPCINT XPTR,XSP,FAIL,RETNUL ;00001971 ; Try conversion to INTEGER 00001972 ;_ 00001973 ;---------------------------------------------------------------------* 00001974 ; 00001975 ; Arithmetic Negative 00001976 ; 00001977 MNS: PROC , ;-X 00001978 RCALL XPTR,ARGVAL,,FAIL ;Get argument 00001979 VEQLC XPTR,I,,MNSM ;INTEGER acceptable 00001980 VEQLC XPTR,S,,MNSV ;STRING must be converted 00001981 VEQLC XPTR,R,INTR1,MNSR ;REAL is acceptable 00001982 ;_ 00001983 MNSM: MNSINT ZPTR,XPTR,AERROR,ARTN ;00001984 ; Form negative of integer 00001985 ;_ 00001986 MNSV: LOCSP XSP,XPTR ;Get specifier for string 00001987 SPCINT XPTR,XSP,,MNSM ;Convert to INTEGER 00001988 SPREAL XPTR,XSP,INTR1 ;Convert to REAL 00001989 MNSR: MNREAL ZPTR,XPTR ;Form negative of real 00001990 BRANCH ARTN ;00001991 ;_ 00001992 ;---------------------------------------------------------------------* 00001993 ; 00001994 ; Unary Plus Operator 00001995 ; 00001996 PLS: PROC , ;+X 00001997 RCALL ZPTR,ARGVAL,,FAIL ;Get argument 00001998 VEQLC ZPTR,I,,ARTN ;Is it INTEGER? 00001999 VEQLC ZPTR,S,,PLSV ;Is it STRING? 00002000 VEQLC ZPTR,R,INTR1,ARTN ;Is it REAL? 00002001 ;_ 00002002 PLSV: LOCSP XSP,ZPTR ;Get specifier 00002003 SPCINT ZPTR,XSP,,ARTN ;Convert STRING to INTEGER 00002004 SPREAL ZPTR,XSP,INTR1,ARTN;Convert STRING to REAL 00002005 ;_ 00002006 ;---------------------------------------------------------------------* 00002007 .PAGE .SBTTL 'Pattern-valued Functions and Operations' ;00002008 .PSECT SNOBOL4_PATTERN_FUNC,SHR,LONG ANY: PROC , ;ANY(S) 00002009 PUSH ANYCCL ;Save function descriptor 00002010 BRANCH CHARZ ;Join common processing 00002011 ;_ 00002012 BREAK: PROC ANY ;BREAK(S) 00002013 PUSH BRKCCL ;Save function descriptor 00002014 PUSH ZEROCL ;Save minimum length of zero 00002015 BRANCH ABNSND ;Join common processing 00002016 ;_ 00002017 NOTANY:PROC ANY ;NOTANY(S) 00002018 PUSH NNYCCL ;Save function descriptor 00002019 BRANCH CHARZ ;00002020 ;_ 00002021 SPAN: PROC ANY ;SPAN(S) 00002022 PUSH SPNCCL ;Save function descriptor 00002023 CHARZ: PUSH CHARCL ;Save minimum length of one 00002024 ABNSND:RCALL XPTR,ARGVAL,,FAIL ;Evaluate argument 00002025 POP ;Restore descriptor and length 00002026 VEQLC XPTR,S,,PATNOD ;STRING is acceptable argument 00002027 VEQLC XPTR,E,,PATNOD ;So is EXPRESSION 00002028 VEQLC XPTR,I,INTR1 ;INTEGER must be converted 00002029 RCALL XPTR,GNVARI,XPTR ;00002030 PATNOD:DEQL XPTR,NULVCL,,NONAME ;E3.5.4 RCALL TPTR,BLOCK,LNODSZ ;E3.5.4 MAKNOD ZPTR,TPTR,ZCL,ZEROCL,YCL,XPTR ;00002032 ; Construct the pattern 00002033 BRANCH RTZPTR ;00002034 ;_ 00002035 LEN: PROC ANY ;LEN(N) 00002036 PUSH LNTHCL ;Save function descriptor 00002037 BRANCH LPRTND ;00002038 ;_ 00002039 POS: PROC ANY ;POS(N) 00002040 PUSH POSICL ;Save function descriptor 00002041 BRANCH LPRTND ;00002042 ;_ 00002043 RPOS: PROC ANY ;RPOS(N) 00002044 PUSH RPSICL ;Save function descriptor 00002045 BRANCH LPRTND ;00002046 ;_ 00002047 RTAB: PROC ANY ;RTAB(N) 00002048 PUSH RTBCL ;Save function descriptor 00002049 BRANCH LPRTND ;00002050 ;_ 00002051 TAB: PROC ANY ;TAB(N) 00002052 PUSH TBCL ;Save function descriptor 00002053 LPRTND:RCALL XPTR,ARGVAL,,FAIL ;Evaluate argument 00002054 POP YCL ;Restore function descriptor 00002055 MOVD ZCL,ZEROCL ;Predict minimum length of zero 00002056 VEQLC XPTR,I,,LPRTNI ;If INTEGER check for LEN 00002057 VEQLC XPTR,E,,PATNOD ;EXPRESSION is acceptable 00002058 VEQLC XPTR,S,INTR1 ;STRING must be converted to INTEGER 00002059 LOCSP ZSP,XPTR ;Get specifier 00002060 SPCINT XPTR,ZSP,INTR1 ;Convert to INTEGER 00002061 LPRTNI:ACOMPC XPTR,0,,,LENERR ;E3.6.1 DEQL YCL,LNTHCL,PATNOD ;E3.6.1 MOVA ZCL,XPTR ;If so, use value of integer 00002063 BRANCH PATNOD ;Go form pattern 00002064 ;_ 00002065 ;---------------------------------------------------------------------* 00002066 ; 00002067 ; ARBNO(P) 00002068 ; 00002069 ARBNO: PROC , ;ARBNO(P) 00002070 RCALL XPTR,PATVAL,,FAIL ;Evaluate argument as pattern 00002071 VEQLC XPTR,P,,ARBP ;PATTERN is desired form 00002072 VEQLC XPTR,S,INTR1 ;STRING must be made into PATTERN 00002073 LOCSP TSP,XPTR ;Get specifier 00002074 GETLG TMVAL,TSP ;Get length of string 00002075 RCALL TPTR,BLOCK,LNODSZ ;Allocate block for argument 00002076 MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR ;00002077 ARBP: GETSIZ XSIZ,XPTR ;Get size of pattern 00002078 SUM TSIZ,XSIZ,ARBSIZ ;Add additional space for ARBNO node 00002079 SETVC TSIZ,P ;Insert PATTERN data type 00002080 RCALL TPTR,BLOCK,TSIZ ;Allocate block for pattern 00002081 MOVD ZPTR,TPTR ;Save pointer to return 00002082 GETSIZ TSIZ,ARHEAD ;Set up copy for heading node 00002083 CPYPAT TPTR,ARHEAD,ZEROCL,ZEROCL,ZEROCL,TSIZ ;00002084 SUM ZSIZ,XSIZ,TSIZ ;00002085 CPYPAT TPTR,XPTR,ZEROCL,TSIZ,ZSIZ,XSIZ ;00002086 SUM TSIZ,NODSIZ,NODSIZ ;Set up size for trailing node 00002087 CPYPAT TPTR,ARTAIL,ZEROCL,ZSIZ,ZEROCL,TSIZ ;00002088 SUM ZSIZ,TSIZ,ZSIZ ;Set up size for backup node 00002089 CPYPAT TPTR,ARBACK,ZEROCL,ZSIZ,TSIZ,TSIZ ;00002090 BRANCH RTZPTR ;00002091 ;_ 00002092 ;---------------------------------------------------------------------* 00002093 ; 00002094 ; @X 00002095 ; 00002096 ATOP: PROC , ;@X 00002097 INCRA OCICL,DESCR ;Increment interpreter offset 00002098 GETD YPTR,OCBSCL,OCICL ;Get object code descriptor 00002099 TESTF YPTR,FNC,ATOP1 ;Test for function descriptor 00002100 RCALL YPTR,INVOKE,YPTR, ;00002101 VEQLC YPTR,E,NEMO ;Only EXPRESSION can be value 00002102 ATOP1: RCALL TPTR,BLOCK,LNODSZ ;Allocate pattern node 00002103 MAKNOD ZPTR,TPTR,ZEROCL,ZEROCL,ATOPCL,YPTR ;00002104 BRANCH RTZPTR ;00002105 ;_ 00002106 ;---------------------------------------------------------------------* 00002107 ; 00002108 ; Value Assignment Operators 00002109 ; 00002110 NAM: PROC , ;X . Y 00002111 PUSH ENMECL ;Save function descriptor 00002112 BRANCH NAM5 ;Join processing 00002113 ;_ 00002114 DOL: PROC NAM ;X $ Y 00002115 PUSH ENMICL ;Save function descritpor 00002116 NAM5: RCALL XPTR,PATVAL,,FAIL ;Get pattern for first argument 00002117 INCRA OCICL,DESCR ;Increment offset 00002118 GETD YPTR,OCBSCL,OCICL ;Get object code descriptor 00002119 TESTF YPTR,FNC,,NAMC2 ;Check for function 00002120 NAM3: VEQLC XPTR,S,,NAMV ;Is first argument STRING? 00002121 VEQLC XPTR,P,INTR1,NAMP ;Is it PATTERN? 00002122 ;_ 00002123 NAMC2: PUSH XPTR ;Save first argument 00002124 RCALL YPTR,INVOKE,YPTR, ;00002125 ; Evaluate second argument 00002126 VEQLC YPTR,E,NEMO ;Verify EXPRESSION 00002127 NAM4: POP XPTR ;Restore first argument 00002128 BRANCH NAM3 ;Join processing 00002129 ;_ 00002130 NAMV: LOCSP TSP,XPTR ;Get specifier 00002131 GETLG TMVAL,TSP ;Get length 00002132 RCALL TPTR,BLOCK,LNODSZ ;Allocate block for pattern 00002133 MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR ;00002134 ; Make pattern node 00002135 NAMP: RCALL TPTR,BLOCK,SNODSZ ;Allocate block for pattern 00002136 MAKNOD WPTR,TPTR,ZEROCL,ZEROCL,NMECL ;00002137 ; Make node for naming 00002138 RCALL TPTR,BLOCK,LNODSZ ;Allocate block for pattern 00002139 POP TVAL ;Restore function descriptor 00002140 MAKNOD YPTR,TPTR,ZEROCL,ZEROCL,TVAL,YPTR ;00002141 ; Make pattern for backup 00002142 GETSIZ XSIZ,XPTR ;Get size of first pattern 00002143 SUM YSIZ,XSIZ,NODSIZ ;Compute total size 00002144 GETSIZ TSIZ,YPTR ;Get size of naming node 00002145 SUM ZSIZ,YSIZ,TSIZ ;Compute total 00002146 SETVC ZSIZ,P ;Insert PATTERN data type 00002147 RCALL TPTR,BLOCK,ZSIZ ;Allocate block for total pattern 00002148 MOVD ZPTR,TPTR ;Save copy 00002149 LVALUE TVAL,XPTR ;Get least value 00002150 CPYPAT TPTR,WPTR,TVAL,ZEROCL,NODSIZ,NODSIZ ;00002151 ; Copy three patterns 00002152 CPYPAT TPTR,XPTR,ZEROCL,NODSIZ,YSIZ,XSIZ ;00002153 CPYPAT TPTR,YPTR,ZEROCL,YSIZ,ZEROCL,TSIZ ;00002154 BRANCH RTZPTR ;Return pattern as value 00002155 ;_ 00002156 ;---------------------------------------------------------------------* 00002157 ; 00002158 ; Binary Alternation Operator 00002159 ; 00002160 OR: PROC , ;X | Y 00002161 RCALL XPTR,PATVAL,,FAIL ;Get first argument 00002162 PUSH XPTR ;Save first argument 00002163 RCALL YPTR,PATVAL,,FAIL ;Get second argument 00002164 POP XPTR ;Restore first argument 00002165 SETAV DTCL,XPTR ;Get first data type 00002166 MOVV DTCL,YPTR ;Insert second data type 00002167 DEQL DTCL,VVDTP,,ORVV ;Is it STRING-STRING? 00002168 DEQL DTCL,VPDTP,,ORVP ;Is it STRING-PATTERN? 00002169 DEQL DTCL,PVDTP,,ORPV ;Is it PATTERN-STRING? 00002170 DEQL DTCL,PPDTP,INTR1,ORPP ;00002171 ; Is it PATTERN_PATTERN? 00002172 ;_ 00002173 ORVV: LOCSP XSP,XPTR ;Get specifier 00002174 GETLG TMVAL,XSP ;Get length 00002175 RCALL TPTR,BLOCK,LNODSZ ;Get block for pattern 00002176 MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR ;00002177 ; Construct pattern 00002178 ORPV: LOCSP YSP,YPTR ;Get specifier 00002179 GETLG TMVAL,YSP ;Get length 00002180 RCALL TPTR,BLOCK,LNODSZ ;Get block for pattern 00002181 MAKNOD YPTR,TPTR,TMVAL,ZEROCL,CHRCL,YPTR ;00002182 ; Construct pattern 00002183 ORPP: GETSIZ XSIZ,XPTR ;Get size of first pattern 00002184 GETSIZ YSIZ,YPTR ;Get size of second pattern 00002185 SUM TSIZ,XSIZ,YSIZ ;Compute total size 00002186 SETVC TSIZ,P ;Insert PATTERN data type 00002187 RCALL TPTR,BLOCK,TSIZ ;Allocate block for pattern 00002188 MOVD ZPTR,TPTR ;Save copy 00002189 CPYPAT TPTR,XPTR,ZEROCL,ZEROCL,ZEROCL,XSIZ ;00002190 ; Copy first pattern 00002191 CPYPAT TPTR,YPTR,ZEROCL,XSIZ,ZEROCL,YSIZ ;00002192 ; Copy second pattern 00002193 LINKOR ZPTR,XSIZ ;Link alternatives 00002194 BRANCH RTZPTR ;Return pattern as value 00002195 ;_ 00002196 ORVP: LOCSP XSP,XPTR ;Get specifier 00002197 GETLG TMVAL,XSP ;Get length 00002198 RCALL TPTR,BLOCK,LNODSZ ;Get block for pattern 00002199 MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR ;00002200 ; Construct pattern 00002201 BRANCH ORPP ;Join processing 00002202 ;_ 00002203 ;---------------------------------------------------------------------* 00002204 .PAGE .SBTTL 'Pattern Matching Procedures' ;00002205 .PSECT SNOBOL4_PATTERN_MATCHING,SHR,LONG ; 00002206 ; Simple Pattern Matching 00002207 ; 00002208 SCAN: PROC , ;Pattern Matching 00002209 RCALL XPTR,ARGVAL,,FAIL ;Get subject 00002210 PUSH XPTR ;Save subject 00002211 RCALL YPTR,PATVAL,,FAIL ;Get pattern 00002212 POP XPTR ;Restore subject 00002213 SETAV DTCL,XPTR ;Set up data type pair 00002214 MOVV DTCL,YPTR ;00002215 INCRA SCNCL,1 ;Increment count of scanner entries 00002216 DEQL DTCL,VVDTP,,SCANVV ;Is it STRING-STRING? 00002217 DEQL DTCL,VPDTP,,SCANVP ;Is it STRING-PATTERN? 00002218 DEQL DTCL,IVDTP,,SCANIV ;Is it INTEGER-STRING? 00002219 DEQL DTCL,RVDTP,,SCANRV ;Is it REAL-STRING? 00002220 DEQL DTCL,RPDTP,,SCANRP ;Is it REAL-PATTERN? 00002221 DEQL DTCL,IPDTP,INTR1,SCANIP ;00002222 ; Is it INTEGER-PATTERN? 00002223 ;_ 00002224 SCANVV:LOCSP XSP,XPTR ;Get specifier for subject 00002225 LOCSP YSP,YPTR ;Get specifier for pattern 00002226 SCANVB:SUBSP TSP,YSP,XSP,FAIL ;Get part to compare 00002227 LEXCMP TSP,YSP,,RETNUL ;Compare strings 00002228 AEQLC ANCCL,0,FAIL ;Check &ANCHOR 00002229 FSHRTN XSP,1 ;Delete lead character 00002230 BRANCH SCANVB ;Try again 00002231 ;_ 00002232 SCANIV:RCALL XPTR,GNVARI,XPTR ;Generate variable for integer 00002233 BRANCH SCANVV ;Join processing 00002234 ;_ 00002235 SCANVP:LOCSP XSP,XPTR ;Get specifier for subject 00002236 RCALL ,SCNR,,;Call scanner 00002237 RCALL ,NMD,, ;Perform naming 00002238 ;_ 00002239 SCANIP:RCALL XPTR,GNVARI,XPTR ;Generate variable for integer 00002240 BRANCH SCANVP ;Join processing 00002241 ;_ 00002242 SCANRV:REALST XSP,XPTR ;Convert REAL to STRING 00002243 RCALL XPTR,GENVAR,XSPPTR,SCANVV ;00002244 ;_ 00002245 SCANRP:REALST XSP,XPTR ;Convert REAL to STRING 00002246 RCALL XPTR,GENVAR,XSPPTR,SCANVP ;00002247 ; Generate variable 00002248 ;_ 00002249 ;_ 00002250 ;---------------------------------------------------------------------* 00002251 ; 00002252 ; Pattern Matching with Replacement 00002253 ; 00002254 SJSR: PROC , ;Pattern matching with replacement 00002255 INCRA OCICL,DESCR ;Increment offset 00002256 GETD WPTR,OCBSCL,OCICL ;Get object code descriptor 00002257 TESTF WPTR,FNC,,SJSRC1 ;Check for function 00002258 SJSR1: AEQLC INSW,0,,SJSR1A ;Check &INPUT 00002259 LOCAPV ZPTR,INATL,WPTR,SJSR1A ;00002260 ; Look of input association 00002261 GETDC ZPTR,ZPTR,DESCR ;Get association 00002262 RCALL XPTR,PUTIN,, ;00002263 ; Perform input 00002264 ;_ 00002265 SJSR1A:GETDC XPTR,WPTR,DESCR ;Get value 00002266 SJSR1B:PUSH ;Save name and value 00002267 RCALL YPTR,PATVAL,,FAIL ;Get pattern 00002268 POP XPTR ;Restore value 00002269 SETAV DTCL,XPTR ;Set up data type pair 00002270 MOVV DTCL,YPTR ;00002271 INCRA SCNCL,1 ;Increment count of scanner calls 00002272 DEQL DTCL,VVDTP,,SJSSVV ;Is it STRING-PATTERN? 00002273 DEQL DTCL,VPDTP,,SJSSVP ;Is it INTEGER-STRING? 00002274 DEQL DTCL,IVDTP,,SJSSIV ;Is it INTEGER-PATTERN? 00002275 DEQL DTCL,RVDTP,,SJSSRV ;Is it REAL-STRING? 00002276 DEQL DTCL,RPDTP,,SJSSRP ;Is it REAL-PATTERN? 00002277 DEQL DTCL,IPDTP,INTR1,SJSSIP ;00002278 ;_ 00002279 SJSRC1:RCALL WPTR,INVOKE,, ;00002280 ; Evaluate subject 00002281 ;_ 00002282 SJSSVP:LOCSP XSP,XPTR ;Get specifier 00002283 RCALL ,SCNR,,;Call scanner 00002284 SETAC NAMGCL,1 ;Set naming switch 00002285 REMSP TAILSP,XSP,TXSP ;Get tail of subject 00002286 BRANCH SJSS1 ;Join common processing 00002287 ;_ 00002288 SJSSIP:RCALL XPTR,GNVARI,XPTR ;Generate STRING from INTEGER 00002289 BRANCH SJSSVP ;Join common processing 00002290 ;_ 00002291 SJSSIV:RCALL XPTR,GNVARI,XPTR ;Generate STRING from INTEGER 00002292 BRANCH SJSSVV ;Join common processing 00002293 ;_ 00002294 SJSSRV:REALST XSP,XPTR ;Convert REAL to STRING 00002295 RCALL XPTR,GENVAR,XSPPTR,SJSSVV ;00002296 ; Generate variable 00002297 ;_ 00002298 SJSSRP:REALST XSP,XPTR ;Convert REAL to STRING 00002299 RCALL XPTR,GENVAR,XSPPTR,SJSSVP ;00002300 ; Generate variable 00002301 ;_ 00002302 SJVVON:AEQLC ANCCL,0,FAIL ;Check &ANCHOR 00002303 ADDLG HEADSP,ONECL ;Increment length of head 00002304 FSHRTN XSP,1 ;Delete head character 00002305 BRANCH SJSSV2 ;Join common processing 00002306 ;_ 00002307 SJSSVV:LOCSP XSP,XPTR ;Get specifier for subject 00002308 LOCSP YSP,YPTR ;Get specifier for pattern 00002309 SETSP HEADSP,XSP ;Set up head specifier 00002310 SETLC HEADSP,0 ;Initialize zero length 00002311 SJSSV2:SUBSP TSP,YSP,XSP,FAIL ;Get common length 00002312 LEXCMP TSP,YSP,SJVVON,,SJVVON ;00002313 ; Compare strings 00002314 SETAC NAMGCL,0 ;Clear naming switch 00002315 REMSP TAILSP,XSP,TSP ;Get tail of subject 00002316 SJSS1: SPUSH ;Save head and tail 00002317 AEQLC NAMGCL,0,,SJSS1A ;Check naming switch 00002318 RCALL ,NMD,,FAIL ;Perform naming 00002319 SJSS1A:RCALL ZPTR,ARGVAL,,FAIL ;Get object 00002320 SPOP ;Restore head and tail 00002321 POP WPTR ;Restore name of subject 00002322 LEQLC HEADSP,0,SJSSDT ;Check for null head 00002323 LEQLC TAILSP,0,,SJSRV1 ;Check for null tail 00002324 SJSSDT:VEQLC ZPTR,S,,SJSRV ;Is object STRING? 00002325 VEQLC ZPTR,P,,SJSRP ;Is object PATTERN? 00002326 VEQLC ZPTR,I,,SJSRI ;Is object INTEGER? 00002327 VEQLC ZPTR,R,,SJSRR ;Is object REAL? 00002328 VEQLC ZPTR,E,INTR1 ;Is object EXPRESSION? 00002329 RCALL TPTR,BLOCK,STARSZ ;Allocate block for pattern 00002330 MOVBLK TPTR,STRPAT,STARSZ ;Set up pattern for expression 00002331 PUTDC TPTR,4*DESCR,ZPTR ;Insert object 00002332 MOVD ZPTR,TPTR ;Set up converted value 00002333 SJSRP: SETSP XSP,HEADSP ;Copy specifier 00002334 RCALL XPTR,GENVAR, ;00002335 ; Generate variable for head 00002336 GETLG TMVAL,HEADSP ;Get length of head 00002337 RCALL TPTR,BLOCK,LNODSZ ;Allocate block for pattern 00002338 MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR ;00002339 ; Make pattern node 00002340 SETSP YSP,TAILSP ;Set up tail specifier 00002341 RCALL YPTR,GENVAR, ;00002342 ; Generate variable for tail 00002343 GETLG TMVAL,TAILSP ;Get length of tail 00002344 RCALL TPTR,BLOCK,LNODSZ ;Allocate block for pattern 00002345 MAKNOD YPTR,TPTR,TMVAL,ZEROCL,CHRCL,YPTR ;00002346 ; Make pattern node 00002347 GETSIZ XSIZ,XPTR ;Get size of head node 00002348 GETSIZ YSIZ,YPTR ;Get size of tail node 00002349 GETSIZ ZSIZ,ZPTR ;Get size of object 00002350 SUM TSIZ,XSIZ,ZSIZ ;Compute total size 00002351 SUM TSIZ,TSIZ,YSIZ ;Get size of new pattern 00002352 SETVC TSIZ,P ;Insert PATTERN data type 00002353 RCALL TPTR,BLOCK,TSIZ ;Allocate block for total pattern 00002354 MOVD VVAL,TPTR ;Get working copy 00002355 LVALUE TVAL,ZPTR ;Get least value of replacement 00002356 CPYPAT TPTR,XPTR,TVAL,ZEROCL,XSIZ,XSIZ ;00002357 ; Copy in head 00002358 LVALUE TVAL,YPTR ;Get least value of tail 00002359 SUM TSIZ,XSIZ,ZSIZ ;Get size of first two 00002360 CPYPAT TPTR,ZPTR,TVAL,XSIZ,TSIZ,ZSIZ ;00002361 ; Copy in object 00002362 CPYPAT TPTR,YPTR,ZEROCL,TSIZ,ZEROCL,YSIZ ;00002363 ; Copy in tail 00002364 MOVD ZPTR,VVAL ;Set up return value 00002365 BRANCH SJSRV1 ;Join common processing 00002366 ;_ 00002367 SJSRV: LOCSP ZSP,ZPTR ;00002368 SJSRS: GETLG XPTR,TAILSP ;Get length of tail 00002369 GETLG YPTR,HEADSP ;Get length of tail 00002370 GETLG ZPTR,ZSP ;Get length of object 00002371 SUM XPTR,XPTR,YPTR ;Compute total length 00002372 SUM XPTR,XPTR,ZPTR ;00002373 ACOMP XPTR,MLENCL,INTR8 ;Check &MAXLNGTH 00002374 RCALL ZPTR,CONVAR, ;Allocate storage for string 00002375 LOCSP TSP,ZPTR ;Get specifier 00002376 SETLC TSP,0 ;Clear length 00002377 APDSP TSP,HEADSP ;Append head 00002378 APDSP TSP,ZSP ;Append object 00002379 APDSP TSP,TAILSP ;Append tail 00002380 RCALL ZPTR,GNVARS,XPTR ;Enter string into storage 00002381 SJSRV1:PUTDC WPTR,DESCR,ZPTR ;Assign value to subject name 00002382 AEQLC OUTSW,0,,SJSRV2 ;Check &OUTPUT 00002383 LOCAPV YPTR,OUTATL,WPTR,SJSRV2 ;00002384 ; Look for output association 00002385 GETDC YPTR,YPTR,DESCR ;Get output association 00002386 RCALL ,PUTOUT,;Perform output 00002387 SJSRV2:ACOMPC TRAPCL,0,,RTN3,RTN3;Check &TRACE 00002388 LOCAPT ATPTR,TVALL,WPTR,RTN3 ;00002389 ; Look for VALUE trace 00002390 RCALL ,TRPHND,ATPTR,RTN3 ;E3.3.1 ; Perform trace 00002392 ;_ 00002393 SJSRI: INTSPC ZSP,ZPTR ;Convert INTEGER 00002394 BRANCH SJSRS ;00002395 ;_ 00002396 SJSRR: REALST ZSP,ZPTR ;Convert REAL 00002397 BRANCH SJSRS ;00002398 ;_ 00002399 ;---------------------------------------------------------------------* 00002400 ; 00002401 ; Basic Scanning Procedure 00002402 ; 00002403 SCNR: PROC , ;Scanning procedure 00002404 GETLG MAXLEN,XSP ;Get maximum length 00002405 LVALUE YSIZ,YPTR ;Get least value 00002406 AEQLC FULLCL,0,SCNR1 ;Check &FULLSCAN 00002407 ACOMP YSIZ,MAXLEN,FAIL ;CHeck maximum against minimum 00002408 SCNR1: SETSP TXSP,XSP ;Set up working specifier for head 00002409 SETLC TXSP,0 ;Zero length 00002410 MOVD PDLPTR,PDLHED ;Initialize history list 00002411 MOVD NAMICL,NHEDCL ;Initialize name list 00002412 AEQLC ANCCL,0,SCNR3 ;Check &ANCHOR 00002413 AEQLC FULLCL,0,,SCNR4 ;Check &FULLSCAN 00002414 MOVD YSIZ,MAXLEN ;Set up length 00002415 BRANCH SCNR5 ;Join processing 00002416 ;_ 00002417 SCNR4: SUBTRT YSIZ,MAXLEN,YSIZ ;Get difference of lengths 00002418 SCNR5: SUM YSIZ,YSIZ,CHARCL ;Add one 00002419 SCNR2: PUSH ;Save pattern and length 00002420 SETSP HEADSP,TXSP ;Set up head specifier 00002421 INCRA PDLPTR,3*DESCR ;Make room for history entry 00002422 ACOMP PDLPTR,PDLEND,INTR31 ;00002423 ; Check for overflow 00002424 SETAC LENFCL,1 ;Set length failure 00002425 PUTDC PDLPTR,DESCR,SCONCL;Insert scan function 00002426 GETLG TMVAL,TXSP ;Get cursor position 00002427 PUTDC PDLPTR,2*DESCR,TMVAL ;00002428 ; Insert on history list 00002429 PUTDC PDLPTR,3*DESCR,LENFCL ;00002430 ; Insert length failure 00002431 BRANCH SCIN1 ;Join common scanning 00002432 ;_ 00002433 SCNR3: INCRA PDLPTR,3*DESCR ;Make room for history entry 00002434 ACOMP PDLPTR,PDLEND,INTR31 ;00002435 ; Check for overflow 00002436 SETLC HEADSP,0 ;Zero length of head 00002437 PUTDC PDLPTR,DESCR,SCFLCL;Insert scan failure function 00002438 GETLG TMVAL,TXSP ;Get cursor position 00002439 PUTDC PDLPTR,2*DESCR,TMVAL ;00002440 ; Insert on history list 00002441 PUTDC PDLPTR,3*DESCR,LENFCL ;00002442 ; Insert length failure 00002443 BRANCH SCIN1 ;Join common scanning 00002444 ;_ 00002445 SCIN: PROC SCNR ;00002446 SCIN1: MOVD PATBCL,YPTR ;Set up pattern base pointer 00002447 SETAC PATICL,0 ;Zero offset 00002448 SCIN2: SETAC LENFCL,1 ;Set length failure 00002449 SCIN3: INCRA PATICL,DESCR ;Increment offset 00002450 GETD ZCL,PATBCL,PATICL ;Get function descriptor 00002451 INCRA PATICL,DESCR ;Increment offset 00002452 GETD XCL,PATBCL,PATICL ;Get then-or descriptor 00002453 INCRA PATICL,DESCR ;Increment offset 00002454 GETD YCL,PATBCL,PATICL ;Get value-residual descriptor 00002455 INCRA PDLPTR,3*DESCR ;Make room for history entry 00002456 ACOMP PDLPTR,PDLEND,INTR31 ;00002457 ; Check for overflow 00002458 PUTDC PDLPTR,DESCR,XCL ;Insert then-or descriptor 00002459 GETLG TMVAL,TXSP ;Get cursor position 00002460 MOVV TMVAL,YCL ;Insert residual 00002461 PUTDC PDLPTR,2*DESCR,TMVAL ;00002462 ; Insert on history list 00002463 PUTDC PDLPTR,3*DESCR,LENFCL ;00002464 ; Insert length failure 00002465 AEQLC FULLCL,0,SCIN4 ;Check &FULLSCAN 00002466 CHKVAL MAXLEN,YCL,TXSP,SALT1 ;00002467 ; Check values 00002468 SCIN4: BRANIC ZCL,0 ;Branch to procedure 00002469 ;_ 00002470 SALF: PROC SCNR ;Nonlength failure procedure 00002471 SALF1: SETAC LENFCL,0 ;Clear length failure 00002472 BRANCH SALT2 ;Join common processing 00002473 ;_ 00002474 SALT: PROC SCNR ;Length failure procedure 00002475 SALT1: GETDC LENFCL,PDLPTR,3*DESCR ;00002476 ; Get length failure from history 00002477 SALT2: GETDC XCL,PDLPTR,DESCR ;Get then-or descriptor 00002478 GETDC YCL,PDLPTR,2*DESCR ;Get value-residual 00002479 DECRA PDLPTR,3*DESCR ;Back over history entry 00002480 MOVD PATICL,XCL ;Set offset to OR link 00002481 AEQLC PATICL,0,,SALT3 ;Check for none 00002482 PUTLG TXSP,YCL ;Insert old length of head 00002483 TESTF PATICL,FNC,SCIN3 ;Check for function 00002484 BRANIC PATICL,0 ;Branch to procedure 00002485 ;_ 00002486 SALT3: AEQLC LENFCL,0,SALT1 ;Check length failure 00002487 BRANCH SALF1 ;Go to nonlength failure 00002488 ;_ 00002489 SCOK: PROC SCNR ;Successful scanning procedure 00002490 SETAV PATICL,XCL ;Set offset from THEN link 00002491 AEQLC PATICL,0,SCIN2,RTN2;Check for none 00002492 ;_ 00002493 SCON: PROC SCNR ;00002494 AEQLC FULLCL,0,SCON1 ;Check &FULLSCAN 00002495 AEQLC LENFCL,0,FAIL ;Check length failure 00002496 SCON1: POP ;Restore save descriptors 00002497 DECRA YSIZ,1 ;Decrement possible count 00002498 ACOMPC YSIZ,0,,FAIL,INTR13;CHeck for end 00002499 ADDLG TXSP,ONECL ;Increment length of head 00002500 BRANCH SCNR2 ;Continue 00002501 ;_ 00002502 UNSC: PROC SCNR ;Backout procedure 00002503 MOVD PATBCL,YPTR ;Reset pattern base 00002504 BRANCH SALT3 ;Join processing 00002505 ;_ 00002506 ;---------------------------------------------------------------------* 00002507 ; 00002508 ; ANY, BREAK, NOTANY, SPAN 00002509 ; 00002510 ANYC: PROC , ;Matching procedure for ANY(S) 00002511 SETAC SCL,1 ;Post entry 00002512 ABNS: INCRA PATICL,DESCR ;Increment offset 00002513 GETD XPTR,PATBCL,PATICL ;Get argument 00002514 PUSH SCL ;Save processor switch 00002515 ABNS1: VEQLC XPTR,S,,ABNSV ;E3.5.5 VEQLC XPTR,E,,ABNSE ;EXPRESSION must be evaluated 00002518 VEQLC XPTR,I,,ABNSI ;E3.5.6 POP SCL ;E3.5.6 BRANCH SCDTER ;E3.5.6 ;_ E3.5.6 ABNSE: RCALL XPTR,EXPVAL,XPTR, ;E3.5.5 ;_ E3.5.5 ABNSF: POP SCL ;E3.5.5 BRANCH TSALF ;E3.5.5 ;_ E3.5.5 ABNSI: RCALL XPTR,GNVARI,XPTR ;00002521 ABNSV: POP SCL ;Restore procedure switch 00002522 AEQLC XPTR,0,,SCNAME ;E3.5.5 SELBRA SCL,<,BRKV,NNYV,SPNV> ;00002523 ; Select processor 00002524 ANYV: DEQL XPTR,TBLCS,ANYC2 ;Was last argument the same? 00002525 AEQL TBLFNC,ANYCCL,,ANYC3 ;00002526 ; If so, was last procedure for ANY(S) 00002527 ANYC2: CLERTB SNABTB,ERROR ;If not, clear stream table 00002528 LOCSP YSP,XPTR ;00002529 PLUGTB SNABTB,STOP,YSP ;Plug entries for characters 00002530 MOVD TBLCS,XPTR ;Save argument to check next time 00002531 MOVD TBLFNC,ANYCCL ;Save procedure to check next time 00002532 ANYC3: SETSP VSP,XSP ;Set up working specifier 00002533 AEQLC FULLCL,0,ANYC4 ;Leave length alone in FULLSCAN mode 00002534 PUTLG VSP,MAXLEN ;Else insert maximum length 00002535 LCOMP VSP,TXSP,,,TSALT ;Length failure if too short 00002536 CHKVAL MAXLEN,ZEROCL,XSP,,ANYC4,ANYC4 ;E3.5.7 ADDLG VSP,ONECL ;E3.5.7 ANYC4: REMSP YSP,VSP,TXSP ;Get specifier to unscanned portion 00002537 STREAM ZSP,YSP,SNABTB,TSALF,TSALT ;00002538 GETLG XPTR,ZSP ;Get length accepted 00002539 ADDLG TXSP,XPTR ;Add to length matched 00002540 BRANCH SCOK,SCNR ;Return to success point 00002541 ;_ 00002542 BRKC: PROC ANYC ;Matching procedure for BREAK(S) 00002543 SETAC SCL,2 ;Post entry 00002544 BRANCH ABNS ;00002545 ;_ 00002546 BRKV: DEQL XPTR,TBLCS,BRKC2 ;Was last argument the same? 00002547 AEQL TBLFNC,BRKCCL,,ANYC3 ;00002548 ; Was the last procedure for BREAK 00002549 BRKC2: CLERTB SNABTB,CONTIN ;If not, clear stream table 00002550 LOCSP YSP,XPTR ;00002551 PLUGTB SNABTB,STOPSH,YSP ;Plug entries for characters 00002552 MOVD TBLCS,XPTR ;Save argument to check next time 00002553 MOVD TBLFNC,BRKCCL ;Save procedure to check next time 00002554 BRANCH ANYC3 ;Proceed 00002555 ;_ 00002556 NNYC: PROC ANYC ;Matching procedure for NOTANY(S) 00002557 SETAC SCL,3 ;Post entry 00002558 BRANCH ABNS ;00002559 ;_ 00002560 NNYV: DEQL XPTR,TBLCS,NNYC2 ;Was last argument the same? 00002561 AEQL TBLFNC,NNYCCL,,ANYC3 ;00002562 ; Was the last procedure for NOTANY? 00002563 NNYC2: CLERTB SNABTB,STOP ;If not, clear stream table 00002564 LOCSP YSP,XPTR ;00002565 PLUGTB SNABTB,ERROR,YSP ;Plug entries for characters 00002566 MOVD TBLCS,XPTR ;Save argument to check next time 00002567 MOVD TBLFNC,NNYCCL ;Save procedure to check next time 00002568 BRANCH ANYC3 ;Proceed 00002569 ;_ 00002570 SPNC: PROC ANYC ;Matching procedure for SPAN(S) 00002571 SETAC SCL,4 ;Post entry 00002572 BRANCH ABNS ;00002573 ;_ 00002574 SPNV: DEQL XPTR,TBLCS,SPNC2 ;Was last argument the same? 00002575 AEQL TBLFNC,SPNCCL,,SPNC3 ;00002576 ; Was the last procedure for SPAN? 00002577 SPNC2: CLERTB SNABTB,STOPSH ;If not, clear stream table 00002578 LOCSP YSP,XPTR ;00002579 PLUGTB SNABTB,CONTIN,YSP ;Plug entries for characters 00002580 MOVD TBLCS,XPTR ;Save argument to check next time 00002581 MOVD TBLFNC,SPNCCL ;Save procedure to check next time 00002582 SPNC3: LCOMP XSP,TXSP,,TSALT,TSALT ;00002583 ; Length failure if too short 00002584 REMSP YSP,XSP,TXSP ;Get specifier to unscanned portion 00002585 STREAM ZSP,YSP,SNABTB,TSALF ;00002586 LEQLC ZSP,0,,TSALF ;Failure if length accepted is zero 00002587 GETLG XPTR,ZSP ;Get length of accepted portion 00002588 AEQLC FULLCL,0,SPNC5 ;Skip length check in FULLSCAN mode 00002589 CHKVAL MAXLEN,XPTR,TXSP,TSALT ;00002590 SPNC5: ADDLG TXSP,XPTR ;Add length accepted 00002591 BRANCH SCOK,SCNR ;00002592 ;_ 00002593 ;---------------------------------------------------------------------* 00002594 ; 00002595 ; LEN, POS, RPOS, RTAB, TAB 00002596 ; 00002597 LNTH: PROC , ;Matching procedure for LEN(N) 00002598 SETAC SCL,1 ;Note entry 00002599 LPRRT: INCRA PATICL,DESCR ;Increment offset 00002600 GETD XPTR,PATBCL,PATICL ;Get argument 00002601 PUSH SCL ;Save entry indicator 00002602 ; 00002603 LPRRT1:VEQLC XPTR,I,,LPRRTI ;Is it INTEGER? 00002604 VEQLC XPTR,E,,LPRRTE ;Is it EXPRESSION? 00002605 VEQLC XPTR,S,,LPRRTV ;E3.5.6 POP SCL ;E3.5.6 BRANCH SCDTER ;E3.5.6 ; Is it STRING? 00002607 LPRRTE:RCALL XPTR,EXPVAL,XPTR,<,LPRRT1> ;E3.2.1 POP SCL ;E3.2.1 BRANCH TSALF ;E3.2.1 ;_ E3.2.1 ; Evaluate EXPRESSION 00002609 LPRRTV:LOCSP ZSP,XPTR ;Get specifier 00002610 SPCINT XPTR,ZSP,SCDTER ;Convert to INTEGER 00002611 LPRRTI:POP SCL ;Restore entry indicator 00002612 SELBRA SCL,<,POSII,RPSII,RTBI,TBI> ;00002613 ; Select matching procedure 00002614 ACOMPC XPTR,0,,,SCLENR ;Check for negative length 00002615 CHKVAL MAXLEN,XPTR,TXSP,TSALT ;00002616 ; Compare with maximum length 00002617 ADDLG TXSP,XPTR ;Add to length matched 00002618 BRANCH SCOK,SCNR ;Return successful match 00002619 ;_ 00002620 POSII: ACOMPC XPTR,0,,,SCLENR ;Check for negative position 00002621 GETLG NVAL,TXSP ;Get cursor position 00002622 ACOMP XPTR,MAXLEN,TSALT ;Check desired against maximum 00002623 ACOMP XPTR,NVAL,TSALF,TSCOK ;00002624 ; Ceck against cursor position 00002625 BRANCH SALT,SCNR ;00002626 ;_ 00002627 RPSII: ACOMPC XPTR,0,,,SCLENR ;Check for negative position 00002628 GETLG NVAL,XSP ;Get total length 00002629 SUBTRT TVAL,NVAL,XPTR ;Find desired position 00002630 GETLG NVAL,TXSP ;Get cursor position 00002631 ACOMP NVAL,TVAL,TSALT,TSCOK,TSALF ;00002632 ; Compare two positions 00002633 ;_ 00002634 RTBI: ACOMPC XPTR,0,,,SCLENR ;Check for negative length 00002635 GETLG NVAL,XSP ;Get total length 00002636 SUBTRT TVAL,NVAL,XPTR ;Find desired position 00002637 GETLG NVAL,TXSP ;Get current position 00002638 ACOMP NVAL,TVAL,TSALT ;Compare two positions 00002639 AEQLC FULLCL,0,RTBII ;Check &FULLSCAN 00002640 SETAV NVAL,YCL ;Get residual 00002641 SUBTRT NVAL,MAXLEN,NVAL ;Find maximum allowed position 00002642 ACOMP NVAL,TVAL,,,TSALT ;Compare with desired position 00002643 RTBII: PUTLG TXSP,TVAL ;Update length of string matched 00002644 BRANCH SCOK,SCNR ;00002645 ;_ 00002646 TBI: ACOMPC XPTR,0,,,SCLENR ;Check for negative length 00002647 GETLG NVAL,TXSP ;Get cursor position 00002648 ACOMP NVAL,XPTR,TSALT ;Check against desired position 00002649 ACOMP XPTR,MAXLEN,TSALT ;Check for tab beyond end 00002650 PUTLG TXSP,XPTR ;Update length of string matched 00002651 BRANCH SCOK,SCNR ;00002652 ;_ 00002653 POSI: PROC LNTH ;Matching procedure for POS(N) 00002654 SETAC SCL,2 ;Note entry 00002655 BRANCH LPRRT ;Join common processing 00002656 ;_ 00002657 RPSI: PROC LNTH ;Matching procedure for RPOS(N) 00002658 SETAC SCL,3 ;Note entry 00002659 BRANCH LPRRT ;Join common processing 00002660 ;_ 00002661 RTB: PROC LNTH ;Matching procedure for RTAB(N) 00002662 SETAC SCL,4 ;Note entry 00002663 BRANCH LPRRT ;Join common processing 00002664 ;_ 00002665 TB: PROC LNTH ;Matching procedure for TAB(N) 00002666 SETAC SCL,5 ;Note entry 00002667 BRANCH LPRRT ;Join common processing 00002668 ;_ 00002669 ;---------------------------------------------------------------------* 00002670 ; 00002671 ; ARBNO 00002672 ; 00002673 ARBN: PROC , ;Matching for ARBNO(P) 00002674 GETLG TMVAL,TXSP ;Get cursor position 00002675 PUSH TMVAL ;Save cursor position 00002676 BRANCH SCOK,SCNR ;Return matching successfully 00002677 ;_ 00002678 ARBF: PROC ARBN ;Backup matching for ARBNO(P) 00002679 POP ;Restore cursor position 00002680 BRANCH ONAR2 ;Join common processing 00002681 ;_ 00002682 EARB: PROC ARBN ;00002683 POP ;Restore cursor position 00002684 PUTDC PDLPTR,DESCR,TMVAL ;Insert on history list 00002685 GETLG TMVAL,TXSP ;Get cursor position 00002686 PUTDC PDLPTR,2*DESCR,TMVAL ;00002687 PUTDC PDLPTR,3*DESCR,ZEROCL ;00002688 BRANCH SCOK,SCNR ;Return matching successfully 00002689 ;_ 00002690 ONAR: PROC ARBN ;00002691 AEQLC FULLCL,0,TSCOK ;Check &FULLSCAN 00002692 MOVD TVAL,ZEROCL ;00002693 GETAC TVAL,PDLPTR,-2*DESCR ;00002694 ; Get old cursor position 00002695 GETLG TMVAL,TXSP ;Get current cursor position 00002696 ACOMP TVAL,TMVAL,TSCOK,,TSCOK ;00002697 ; Compare positions 00002698 ONAR1: PUSH TVAL ;Save cursor position 00002699 DECRA PDLPTR,6*DESCR ;Delete history entries 00002700 ONAR2: AEQLC LENFCL,0,TSALT ;Check length failure 00002701 BRANCH SALF,SCNR ;Return matching failure 00002702 ;_ 00002703 ONRF: PROC ARBN ;00002704 MOVD TVAL,ZEROCL ;00002705 GETAC TVAL,PDLPTR,-2*DESCR ;00002706 ; Get old cursor position 00002707 BRANCH ONAR1 ;Join processing 00002708 ;_ 00002709 FARB: PROC , ;00002710 AEQLC FULLCL,0,,FARB2 ;Check &FULLSCAN 00002711 SETAC NVAL,0 ;Set residual length to 0 00002712 BRANCH FARB3 ;Join processing 00002713 ;_ 00002714 FARB2: AEQLC LENFCL,0,FARB1 ;Check for length failure 00002715 SETAV NVAL,YCL ;Get residual length 00002716 FARB3: GETLG TVAL,TXSP ;Get cursor position 00002717 SUM TVAL,TVAL,NVAL ;Add them 00002718 ACOMP TVAL,MAXLEN,FARB1,FARB1 ;00002719 ; Check against maximum 00002720 ADDLG TXSP,ONECL ;Add one for ARB 00002721 GETLG TVAL,TXSP ;Get length matched 00002722 PUTAC PDLPTR,2*DESCR,TVAL;Insert on history list 00002723 BRANCH SCOK,SCNR ;Return successful match 00002724 ;_ 00002725 FARB1: DECRA PDLPTR,3*DESCR ;Back over history entry 00002726 BRANCH SALT,SCNR ;00002727 ;_ 00002728 ;---------------------------------------------------------------------* 00002729 ; 00002730 ; @X 00002731 ; 00002732 ATP: PROC , ;Matching procedure for @X 00002733 INCRA PATICL,DESCR ;Increment pattern offset 00002734 GETD XPTR,PATBCL,PATICL ;Get argument 00002735 ATP1: VEQLC XPTR,E,,ATPEXN ;EXPRESSION must be evaluated 00002736 GETLG NVAL,TXSP ;Get length of text matched 00002737 SETVC NVAL,I ;Set INTEGER data type 00002738 PUTDC XPTR,DESCR,NVAL ;Assign as value of variable X 00002739 AEQLC OUTSW,0,,ATP2 ;Check &OUTPUT 00002740 LOCAPV ZPTR,OUTATL,XPTR,ATP2 ;00002741 ; Look for output association 00002742 GETDC ZPTR,ZPTR,DESCR ;Get output association descriptor 00002743 RCALL ,PUTOUT,;Perform output 00002744 ATP2: AEQLC TRAPCL,0,,TSCOK ;Check &TRACE 00002745 LOCAPT ATPTR,TVALL,XPTR,TSCOK ;00002746 ; Look for trace association 00002747 PUSH ;00002748 PUSH ;00002749 SPUSH ;00002750 MOVD PDLHED,PDLPTR ;Set new stack heading 00002751 MOVD NHEDCL,NAMICL ;Set new name list heading 00002752 RCALL ,TRPHND,ATPTR ;E3.3.1 ; Perform tracing 00002754 SPOP ;00002755 POP ;00002756 POP ;00002757 BRANCH SCOK,SCNR ;00002758 ;_ 00002759 ATPEXN:RCALL XPTR,EXPEVL,XPTR, ;E3.4.4 ;_ 00002761 ;---------------------------------------------------------------------* 00002762 ; 00002763 ; BAL 00002764 ; 00002765 BAL: PROC , ;Matching procedure for BAL 00002766 BALF1: AEQLC FULLCL,0,,BALF4 ;Check &FULLSCAN 00002767 SETAC NVAL,0 ;Set length to zero 00002768 BRANCH BALF2 ;00002769 ;_ 00002770 BALF4: SETAV NVAL,YCL ;00002771 BALF2: GETLG TVAL,TXSP ;Get length of text matched so far 00002772 SUM TVAL,TVAL,NVAL ;Add remainder possible 00002773 ACOMP TVAL,MAXLEN,BAL1,BAL1 ;00002774 ; Compare to maximum 00002775 SUBTRT TVAL,MAXLEN,TVAL ;Get maximum length for BAL 00002776 GETBAL TXSP,TVAL,BAL1 ;Get balanced string 00002777 GETLG TVAL,TXSP ;Get length matched 00002778 PUTAC PDLPTR,2*DESCR,TVAL;Insert history entry 00002779 BRANCH SCOK,SCNR ;Successful match 00002780 ;_ 00002781 BAL1: DECRA PDLPTR,3*DESCR ;Back over history entry 00002782 ACOMP PDLPTR,PDLHED,TSALF,TSALF,INTR13 ;00002783 ;_ 00002784 BALF: PROC BAL ;Matching procedure for BAL retry 00002785 AEQLC FULLCL,0,,BALF3 ;Check &FULLSCAN 00002786 SETAC NVAL,0 ;If off, set length to zero 00002787 BRANCH BALF2 ;Reenter balanced matching 00002788 ;_ 00002789 BALF3: AEQLC LENFCL,0,BAL1,BALF1;If on, test for length failure 00002790 ;_ 00002791 ;---------------------------------------------------------------------* 00002792 ; 00002793 ; Matching for String 00002794 ; 00002795 CHR: PROC , ;Matching character string 00002796 INCRA PATICL,DESCR ;Increment offset 00002797 GETD YPTR,PATBCL,PATICL ;Get argument 00002798 CHR1: LOCSP TSP,YPTR ;Get specifier 00002799 CHR2: REMSP VSP,XSP,TXSP ;Remove part matched 00002800 SUBSP VSP,TSP,VSP,TSALT ;Get part to match 00002801 LEXCMP VSP,TSP,TSALF,,TSALF ;00002802 ; Compare strings 00002803 GETLG YPTR,TSP ;Get length 00002804 ADDLG TXSP,YPTR ;Update string matched 00002805 BRANCH SCOK,SCNR ;Return successful match 00002806 ;_ 00002807 ;---------------------------------------------------------------------* 00002808 ; 00002809 ; *X 00002810 ; 00002811 STAR: PROC CHR ;Matching procedure for expressions 00002812 INCRA PATICL,DESCR ;Increment offset 00002813 GETD YPTR,PATBCL,PATICL ;Get argument expression 00002814 STAR2: RCALL YPTR,EXPVAL,YPTR,TSALF ;00002815 ; Evaluate argument 00002816 VEQLC YPTR,E,,STAR2 ;Is is EXPRESSION? 00002817 SUM XPTR,PATBCL,PATICL ;Compute pointer to argument 00002818 PUTDC XPTR,7*DESCR,YPTR ;Insert pointer in backup node 00002819 VEQLC YPTR,S,,CHR1 ;Is it STRING? 00002820 VEQLC YPTR,P,,STARP ;Is it PATTERN? 00002821 VEQLC YPTR,I,SCDTER ;Is it INTEGER? 00002822 INTSPC TSP,YPTR ;Get specifier for integer 00002823 BRANCH CHR2 ;Join processing 00002824 ;_ 00002825 STARP: AEQLC FULLCL,0,,STARP1 ;Check &FULLSCAN 00002826 SETAC NVAL,0 ;Zero length 00002827 BRANCH STARP4 ;Join processing 00002828 ;_ 00002829 STARP1:SETAV NVAL,YCL ;Get length 00002830 STARP4:SUBTRT NVAL,MAXLEN,NVAL ;Compute residual 00002831 ACOMPC NVAL,0,,,TSALT ;00002832 LVALUE TSIZ,YPTR ;Check &FULLSCAN 00002833 AEQLC FULLCL,0,STARP6 ;00002834 ACOMP TSIZ,NVAL,TSALT ;Check against length 00002835 STARP6:INCRA PDLPTR,3*DESCR ;Make room for history 00002836 ACOMP PDLPTR,PDLEND,INTR31 ;00002837 ; Check for overflow 00002838 PUTDC PDLPTR,DESCR,SCFLCL;Insert failure function 00002839 GETLG TMVAL,TXSP ;Get cursor position 00002840 PUTDC PDLPTR,2*DESCR,TMVAL ;00002841 ; Insert on history list 00002842 PUTDC PDLPTR,3*DESCR,LENFCL ;00002843 ; Insert length failure 00002844 PUSH ;00002845 ; Save scanner state 00002846 MOVD MAXLEN,NVAL ;Set up new maximum 00002847 RCALL ,SCIN,, ;00002848 ; Call the scanner 00002849 STARP2:POP ;00002850 ; Restore scanner state 00002851 BRANCH SCOK,SCNR ;Return matching successfully 00002852 ;_ 00002853 STARP5:POP ;00002854 ; Restore scanner state 00002855 STARP3:AEQLC LENFCL,0,TSALT ;Check length failure 00002856 BRANCH SALF,SCNR ;Return matching failure 00002857 ;_ 00002858 DSAR: PROC CHR ;Backup matching for expression 00002859 INCRA PATICL,DESCR ;Increment offset 00002860 GETD YPTR,PATBCL,PATICL ;Get argument 00002861 VEQLC YPTR,S,,STARP3 ;Is it STRING? 00002862 VEQLC YPTR,P,,DSARP ;Is it PATTERN? 00002863 VEQLC YPTR,I,SCDTER,STARP3 ;00002864 ; Is it INTEGER? 00002865 ;_ 00002866 DSARP: AEQLC FULLCL,0,,DSARP1 ;Check &FULLSCAN 00002867 SETAC NVAL,0 ;Zero length 00002868 BRANCH DSARP2 ;Join processing 00002869 ;_ 00002870 DSARP1:SETAV NVAL,YCL ;Get length 00002871 DSARP2:SUBTRT NVAL,MAXLEN,NVAL ;Compute residual 00002872 PUSH ;00002873 ; Save scanner state 00002874 MOVD MAXLEN,NVAL ;Set up new maximum 00002875 RCALL ,UNSC,, ;00002876 ; Call unscanning procedure 00002877 ;_ 00002878 ;---------------------------------------------------------------------* 00002879 ; 00002880 ; FENCE 00002881 ; 00002882 FNCE: PROC , ;Procedure for matching FENCE 00002883 INCRA PDLPTR,3*DESCR ;Create new history entry 00002884 ACOMP PDLPTR,PDLEND,INTR31 ;00002885 ; Check for overflow 00002886 PUTDC PDLPTR,DESCR,FNCFCL;Insert FENCE failure function 00002887 GETLG TMVAL,TXSP ;Get length 00002888 PUTDC PDLPTR,2*DESCR,TMVAL ;00002889 ; Save length 00002890 PUTDC PDLPTR,3*DESCR,LENFCL ;00002891 ; Save length failure switch 00002892 SETAC LENFCL,1 ;Set length failure switch 00002893 BRANIC SCOKCL,0 ;Return matching 00002894 ;_ 00002895 ;---------------------------------------------------------------------* 00002896 ; 00002897 ; X . Y and X $ Y 00002898 ; 00002899 NME: PROC , ;Matching procedure for naming 00002900 INCRA PDLPTR,3*DESCR ;Make room for history entry 00002901 ACOMP PDLPTR,PDLEND,INTR31 ;00002902 ; Check for end of list 00002903 PUTDC PDLPTR,DESCR,FNMECL;Insert backup function 00002904 GETLG TMVAL,TXSP ;Get cursor position 00002905 PUTDC PDLPTR,2*DESCR,TMVAL ;00002906 ; Put on history list 00002907 PUTDC PDLPTR,3*DESCR,LENFCL ;00002908 ; Put length failure indicator 00002909 PUSH ;Save cursor 00002910 SETAC LENFCL,1 ;Set length failure indicator 00002911 BRANCH SCOK,SCNR ;Return matching successfully 00002912 ;_ 00002913 FNME: PROC NME ;Backup procedure for naming 00002914 POP ;Restore cursor 00002915 FNME1: AEQLC LENFCL,0,TSALT,TSALF ;00002916 ; Check length failure indicator 00002917 ;_ 00002918 ENME: PROC NME ;Naming process for X . Y 00002919 INCRA PATICL,DESCR ;Increment offset 00002920 GETD YPTR,PATBCL,PATICL ;Get argument 00002921 POP ;Restore previous cursor position 00002922 SETVA YCL,NVAL ;Set up length 00002923 SETSP TSP,TXSP ;Copy specifier 00002924 PUTLG TSP,NVAL ;Insert length 00002925 REMSP TSP,TXSP,TSP ;Compute ramainder 00002926 SUM TPTR,NBSPTR,NAMICL ;Compute position on name list 00002927 PUTSPC TPTR,DESCR,TSP ;Insert specifier 00002928 PUTDC TPTR,DESCR+SPEC,YPTR ;00002929 ; Insert argument 00002930 INCRA NAMICL,DESCR+SPEC ;Increment list offset 00002931 ACOMP NAMICL,NMOVER,INTR13,ENME1 ;00002932 ; Check for overflow 00002933 ENME2: INCRA PDLPTR,DESCR+SPEC ;Make room on history list 00002934 ACOMP PDLPTR,PDLEND,INTR31 ;00002935 ; Check for overflow 00002936 PUTDC PDLPTR,DESCR,DNMECL;Insert unravelling function 00002937 ENME3: GETLG TMVAL,TXSP ;Get cursor position 00002938 MOVV TMVAL,YCL ;00002939 PUTDC PDLPTR,2*DESCR,TMVAL ;00002940 ; Insert on list 00002941 PUTDC PDLPTR,3*DESCR,LENFCL ;00002942 ; Insert length failure 00002943 SETAC LENFCL,1 ;Set length failure 00002944 BRANCH SCOK,SCNR ;Return matching successfully 00002945 ;_ 00002946 ENME1: MOVD WCL,NMOVER ;Save copy of cuurent name list end 00002947 INCRA NMOVER,NAMLSZ*SPDR ;Increment for larger block 00002948 RCALL TPTR,BLOCK,NMOVER ;Allocate larger block 00002949 MOVBLK TPTR,NBSPTR,WCL ;Move in old block 00002950 MOVD NBSPTR,TPTR ;Set up new base pointer 00002951 BRANCH ENME2 ;Rejoin processing 00002952 ;_ 00002953 DNME: PROC NME ;Unravelling procedure for naming 00002954 DECRA NAMICL,DESCR+SPEC ;Back off named string 00002955 SUM TPTR,NBSPTR,NAMICL ;Compute current position 00002956 DNME1: PROC NME ;00002957 SETAV VVAL,YCL ;00002958 PUSH ;Preserve length 00002959 BRANCH FNME1 ;00002960 ;_ 00002961 ENMI: PROC NME ;Matching for X $ Y 00002962 INCRA PATICL,DESCR ;Increment offset 00002963 GETD YPTR,PATBCL,PATICL ;Get argument 00002964 POP ;Restore initial length 00002965 SETVA YCL,NVAL ;Move initial length into value field 00002966 SETSP TSP,TXSP ;Get working specifier 00002967 PUTLG TSP,NVAL ;Insert length 00002968 REMSP TSP,TXSP,TSP ;Get specifier for part matched 00002969 GETLG ZCL,TSP ;Get length of part 00002970 ACOMP ZCL,MLENCL,SCLNOR ;Check &MAXLNGTH 00002971 VEQLC YPTR,E,,ENMEXN ;Is it EXPRESSION? 00002972 ENMI5: VEQLC YPTR,K,,ENMIC ;Check for KEYWORD data type 00002973 RCALL VVAL,GENVAR, ;00002974 ; Generate variable 00002975 ENMI3: PUTDC YPTR,DESCR,VVAL ;Perform assignment 00002976 AEQLC OUTSW,0,,ENMI4 ;Check &OUTPUT 00002977 LOCAPV ZPTR,OUTATL,YPTR,ENMI4 ;00002978 ; Look for output association 00002979 GETDC ZPTR,ZPTR,DESCR ;Get association 00002980 RCALL ,PUTOUT,;Perform output 00002981 ENMI4: ACOMPC TRAPCL,0,,ENMI2,ENMI2 ;00002982 ; Check &TRACE 00002983 LOCAPT ATPTR,TVALL,YPTR,ENMI2 ;00002984 ; Look for VALUE trace 00002985 PUSH ;00002986 ; Save relevant descriptors 00002987 PUSH ;00002988 SPUSH ;00002989 ; Save relevant specifiers 00002990 MOVD PDLHED,PDLPTR ;Set up new history list head 00002991 MOVD NHEDCL,NAMICL ;Set up new name list head 00002992 RCALL ,TRPHND,ATPTR ;E3.3.1 ; Perform trace 00002994 SPOP ;00002995 ; Restore specifiers 00002996 POP ;00002997 ; Restore descriptors 00002998 POP ;00002999 ENMI2: INCRA PDLPTR,3*DESCR ;Make room on history list 00003000 ACOMP PDLPTR,PDLEND,INTR31 ;00003001 ; Check for overflow 00003002 PUTDC PDLPTR,DESCR,DNMICL;Insert unravelling function 00003003 BRANCH ENME3 ;Join common processing 00003004 ;_ 00003005 ENMIC: SPCINT VVAL,TSP,SCDTER,ENMI3 ;00003006 ; Convert STRING to INTEGER 00003007 ;_ 00003008 ENMEXN:PUSH ZEROCL ;E3.4.4 & E3.5.8 RCALL YPTR,EXPEVL,YPTR, ;E3.4.4 & E3.5.8 POP ZEROCL ;E3.4.4 & E3.5.8 BRANCH ENMI5 ;E3.4.4 & E3.5.8 ;_ 00003011 ;---------------------------------------------------------------------* 00003012 ; 00003013 ; SUCCEED 00003014 ; 00003015 SUCE: PROC , ;Matching procedure for SUCCEED 00003016 SUCE1: INCRA PDLPTR,3*DESCR ;Make room for history entry 00003017 ACOMP PDLPTR,PDLEND,INTR31 ;00003018 ; Check for overflow 00003019 PUTDC PDLPTR,DESCR,SUCFCL;Insert SUCCESS backup function 00003020 GETLG TMVAL,TXSP ;Get length matched 00003021 PUTDC PDLPTR,2*DESCR,TMVAL ;00003022 ; Save on history list 00003023 PUTDC PDLPTR,3*DESCR,LENFCL ;00003024 ; Save current length failure 00003025 SETAC LENFCL,1 ;Set length failure 00003026 BRANIC SCOKCL,0 ;Return successful match 00003027 ;_ 00003028 SUCF: PROC SUCE ;SUCCEED failure 00003029 GETDC XCL,PDLPTR,DESCR ;Get history entries 00003030 GETDC YCL,PDLPTR,2*DESCR ;00003031 BRANCH SUCE1 ;Go in front door 00003032 ;_ 00003033 ;---------------------------------------------------------------------* 00003034 .PAGE .SBTTL 'Defined Functions' ;00003035 .PSECT SNOBOL4_DEFINED,SHR,LONG ; 00003036 ; DEFINE(P,E) 00003037 ; 00003038 DEFINE:PROC , ;DEFINE(P,E) 00003039 RCALL XPTR,VARVAL,,FAIL ;Get prototype 00003040 PUSH XPTR ;Save prototype 00003041 RCALL YPTR,VARVAL,,FAIL ;Get entry point 00003042 POP XPTR ;Restore prototype 00003043 LOCSP XSP,XPTR ;Specifier for prototype 00003044 STREAM YSP,XSP,VARATB,PROTER,PROTER ;00003045 ; Break out function name 00003046 AEQLC STYPE,LPTYP,PROTER ;Verify open parenthesis 00003047 RCALL XPTR,GENVAR, ;00003048 ; Get variable for function name 00003049 RCALL ZCL,FINDEX, ;Get function descriptor for function 00003050 DEQL YPTR,NULVCL,DEFIN3 ;Check for omitted entry point 00003051 MOVD YPTR,XPTR ;If omitted use function name 00003052 DEFIN3:PUSH YPTR ;Save entry point 00003053 MOVD YCL,ZEROCL ;Set argument count to 0 00003054 PUSH XPTR ;Save function name 00003055 DEFIN4:FSHRTN XSP,1 ;Remove break character 00003056 STREAM YSP,XSP,VARATB,PROTER,PROTER ;00003057 ; Break out argument 00003058 SELBRA STYPE, ;00003059 ; Check for end 00003060 LEQLC YSP,0,,DEFIN4 ;Check for null argument 00003061 RCALL XPTR,GENVAR, ;00003062 ; Generate variable for argument 00003063 PUSH XPTR ;Save argument 00003064 INCRA YCL,1 ;Increment argument count 00003065 BRANCH DEFIN4 ;Continue 00003066 ;_ 00003067 DEFIN6:LEQLC YSP,0,,DEFIN9 ;00003068 INCRA YCL,1 ;Increment argument count 00003069 RCALL XPTR,GENVAR, ;00003070 ; Generate variable for argument 00003071 PUSH XPTR ;Save argument 00003072 DEFIN9:SETVA DEFCL,YCL ;00003073 DEFIN8:FSHRTN XSP,1 ;00003074 STREAM YSP,XSP,VARATB,PROTER,DEF10 ;00003075 ; Break out local arguments 00003076 AEQLC STYPE,CMATYP,PROTER;Verify comma 00003077 LEQLC YSP,0,,DEFIN8 ;Check for null argument 00003078 RCALL XPTR,GENVAR, ;00003079 ; Generate variable 00003080 PUSH XPTR ;Save local argument 00003081 INCRA YCL,1 ;Increment total count 00003082 BRANCH DEFIN8 ;Continue 00003083 ;_ 00003084 DEF10: LEQLC YSP,0,,DEF11 ;Check for null argument 00003085 RCALL XPTR,GENVAR,YSPPTR ;Generate variable 00003086 PUSH XPTR ;Save argument 00003087 INCRA YCL,1 ;Increment total count 00003088 DEF11: INCRA YCL,2 ;Increment for name and label 00003089 MULTC XCL,YCL,DESCR ;Convert to address units 00003090 SETVC XCL,B ;Insert block data type 00003091 RCALL XPTR,BLOCK,XCL ;Allocate block for definition 00003092 PUTDC ZCL,0,DEFCL ;Point to procedure descriptor 00003093 PUTDC ZCL,DESCR,XPTR ;Insert definition block 00003094 SUM XPTR,XPTR,XCL ;Compute end of block 00003095 DEF12: DECRA XPTR,DESCR ;Decrement pointer 00003096 POP YPTR ;Restore argument 00003097 PUTDC XPTR,DESCR,YPTR ;Insert in definition block 00003098 DECRA YCL,1 ;Decrement total count 00003099 AEQLC YCL,0,DEF12,RETNUL ;Check for end 00003100 ;_ 00003101 ;---------------------------------------------------------------------* 00003102 ; 00003103 ; Invocation of Defined Function 00003104 ; 00003105 DEFFNC:PROC , ;Procedure to invoke defined function 00003106 SETAV XCL,INCL ;Get number of arguments in call 00003107 MOVD WCL,XCL ;Save copy 00003108 MOVD YCL,INCL ;Save function descriptor 00003109 PSTACK YPTR ;Post stack position 00003110 PUSH NULVCL ;Save null value for function name 00003111 DEFF1: INCRA OCICL,DESCR ;Increment offset 00003112 GETD XPTR,OCBSCL,OCICL ;Get object code descriptor 00003113 TESTF XPTR,FNC,,DEFFC ;Check for function descriptor 00003114 DEFF2: AEQLC INSW,0,,DEFF14 ;Check &INPUT 00003115 LOCAPV ZPTR,INATL,XPTR,DEFF14 ;00003116 ; Look for input association 00003117 GETDC ZPTR,ZPTR,DESCR ;Get association 00003118 PUSH ;Save relevant descriptors 00003119 RCALL XPTR,PUTIN,,FAIL ;00003120 ; Perform input 00003121 POP ;Restore descriptors 00003122 BRANCH DEFF3 ;Join processing 00003123 ;_ 00003124 DEFF14:GETDC XPTR,XPTR,DESCR ;Get value 00003125 DEFF3: PUSH XPTR ;Save value 00003126 DECRA XCL,1 ;Decrement argument count 00003127 ACOMPC XCL,0,DEFF1,,INTR10;Check for end 00003128 GETDC XCL,YCL,0 ;Get expected number of arguments 00003129 SETAV XCL,XCL ;Insert in A-field 00003130 DEFF4: ACOMP WCL,XCL,DEFF9,DEFF5;Compare given and expected 00003131 PUSH NULVCL ;Not enough, save null string 00003132 INCRA WCL,1 ;Increment count 00003133 BRANCH DEFF4 ;Continue 00003134 ;_ 00003135 DEFF9: POP ZCL ;Throw away extra argument 00003136 DECRA WCL,1 ;Decrement count 00003137 BRANCH DEFF4 ;Continue 00003138 ;_ 00003139 DEFF5: GETDC ZCL,YCL,DESCR ;Get definition block 00003140 MOVD XPTR,ZCL ;Save copy 00003141 GETSIZ WCL,ZCL ;Get size of block 00003142 SUM WPTR,ZCL,WCL ;Compute pointer to end 00003143 INCRA XCL,1 ;Increment for function name 00003144 DEFF8: INCRA XPTR,DESCR ;Increment pointer to block 00003145 INCRA YPTR,DESCR ;Adjust stack pointer 00003146 GETDC ZPTR,XPTR,DESCR ;Get argument name 00003147 GETDC TPTR,ZPTR,DESCR ;Get current argument value 00003148 GETDC ATPTR,YPTR,DESCR ;Get value from stack 00003149 PUTDC ZPTR,DESCR,ATPTR ;Assign to argument name 00003150 PUTDC YPTR,DESCR,TPTR ;Put current argument on stack 00003151 DECRA XCL,1 ;Decrement count 00003152 ACOMPC XCL,0,DEFF8,,INTR10;Check for end 00003153 DEFF10:INCRA XPTR,DESCR ;Increment pointer to block 00003154 AEQL XPTR,WPTR,,DEFFGO ;00003155 GETDC ZPTR,XPTR,DESCR ;Get argument name from block 00003156 GETDC TPTR,ZPTR,DESCR ;Get current value of argument 00003157 PUSH TPTR ;Save current value 00003158 PUTDC ZPTR,DESCR,NULVCL ;Assign null value to local 00003159 BRANCH DEFF10 ;Continue 00003160 ;_ 00003161 DEFFGO:PUSH ;00003162 ; Save system state 00003163 GETDC XCL,ZCL,DESCR ;Get entry label 00003164 AEQLIC XCL,ATTRIB,0,,UNDFFE ;E3.0.2 GETDC OCBSCL,XCL,ATTRIB ;E3.0.2 ACOMPC TRACL,0,,DEFF18,DEFF18 ;00003167 ; Check &FTRACE 00003168 DECRA TRACL,1 ;Decrement &FTRACE 00003169 GETDC ATPTR,ZCL,2*DESCR ;Get function name 00003170 PUSH ZCL ;Save definition block 00003171 RCALL ,FENTR2,, ;00003172 ; Perform function trace 00003173 POP ZCL ;Restore definition block 00003174 DEFF18:ACOMPC TRAPCL,0,,DEFF19,DEFF19 ;00003175 ; Check &TRACE 00003176 GETDC ATPTR,ZCL,2*DESCR ;Get function name 00003177 LOCAPT ATPTR,TFENTL,ATPTR,DEFF19 ;00003178 ; Check for CALL trace 00003179 PUSH ;Save object code base and block 00003180 RCALL ,TRPHND,ATPTR ;E3.3.1 ; Perform trace 00003182 POP ;Restore base and block 00003183 DEFF19:INCRA LVLCL,1 ;Increment &FNCLEVEL 00003184 ACOMPC TRAPCL,0,,DEFF15,DEFF15 ;00003185 ; Check &TRACE 00003186 LOCAPT ATPTR,TKEYL,FNCLKY,DEFF15 ;00003187 ; Look for KEYWORD trace 00003188 RCALL ,TRPHND,ATPTR ;E3.3.1 ; Perform trace 00003190 DEFF15:SETAC OCICL,0 ;Zero offset 00003191 RCALL ,INTERP,, ;00003192 ; Call interpreter 00003193 MOVD RETPCL,RETCL ;Set &RTNTYPE to RETURN 00003194 DEFFS1:POP ZCL ;Restore definition block 00003195 ACOMPC TRACL,0,,DEFF20,DEFF20 ;00003196 ; Check &FTRACE 00003197 DECRA TRACL,1 ;Decrement &FTRACE 00003198 GETDC ATPTR,ZCL,2*DESCR ;Get function name 00003199 PUSH ZCL ;Save definition block 00003200 RCALL ,FNEXT2,, ;00003201 ; Perform function trace 00003202 POP ZCL ;Restore definition block 00003203 DEFF20:ACOMPC TRAPCL,0,,DEFFS2,DEFFS2 ;00003204 ; Check &TRACE 00003205 GETDC ATPTR,ZCL,2*DESCR ;Get function name 00003206 LOCAPT ATPTR,TFEXTL,ATPTR,DEFFS2 ;00003207 ; Check for RETURN trace 00003208 PUSH ;Save return and block 00003209 RCALL ,TRPHND,ATPTR ;E3.3.1 ; Perform trace 00003211 POP ;Restore block and return 00003212 DEFFS2:DECRA LVLCL,1 ;Decrement &FNCLEVEL 00003213 ACOMPC TRAPCL,0,,DEFF17,DEFF17 ;00003214 ; Check &TRACE 00003215 LOCAPT ATPTR,TKEYL,FNCLKY,DEFF17 ;00003216 ; Check for KEYWORD trace 00003217 PUSH ;Save return and block 00003218 RCALL ,TRPHND,ATPTR ;E3.3.1 ; Perform trace 00003220 POP ;Restore block and return 00003221 DEFF17:POP ;00003222 ; Restore system state 00003223 GETSIZ WCL,ZCL ;Get size of definition block 00003224 DECRA WCL,DESCR ;Decrement pointer 00003225 ACOMPC WCL,0,,INTR10,INTR10 ;00003226 ; Check for end 00003227 SUM WPTR,ZCL,WCL ;Compute pointer to last descriptor 00003228 MOVD YPTR,ZCL ;Save pointer to block 00003229 INCRA YPTR,DESCR ;Increment pointer 00003230 GETDC ZPTR,YPTR,DESCR ;Get function name 00003231 GETDC ZPTR,ZPTR,DESCR ;Get value to be returned 00003232 DEFF6: POP XPTR ;Get old value 00003233 GETDC YPTR,WPTR,DESCR ;Get argument name 00003234 PUTDC YPTR,DESCR,XPTR ;Restore old value 00003235 DECRA WPTR,DESCR ;Decrement pointer 00003236 AEQL WPTR,ZCL,DEFF6 ;Check for end 00003237 DEQL RETPCL,FRETCL,,FAIL;Check for FRETURN 00003238 DEQL RETPCL,NRETCL,RTZPTR ;00003239 ; Check for NRETURN 00003240 MOVD XPTR,ZPTR ;Move name to correct descriptor 00003241 VEQLC XPTR,S,,DEFFVX ;Check for natural variable 00003242 VEQLC XPTR,I,,GENVIX ;Convert integer 00003243 VEQLC XPTR,N,,RTXNAM ;Check for created variable 00003244 VEQLC XPTR,K,NONAME,RTXNAM ;00003245 ; Check for keyword variable 00003246 DEFFVX:AEQLC XPTR,0,RTXNAM,NONAME ;00003247 ; Check for null string 00003248 ;_ 00003249 DEFFF: MOVD RETPCL,FRETCL ;Set up FRETURN 00003250 BRANCH DEFFS1 ;Join processing 00003251 ;_ 00003252 DEFFC: PUSH ;Save relevant descriptors 00003253 RCALL XPTR,INVOKE,, ;00003254 ; Evaluate argument 00003255 POP ;Restore relevant variables 00003256 BRANCH DEFF3 ;Join processing 00003257 ;_ 00003258 DEFFN: POP ;Restore relevant variables 00003259 BRANCH DEFF2 ;Join processing 00003260 ;_ 00003261 DEFFNR:MOVD RETPCL,NRETCL ;Set up NRETURN 00003262 BRANCH DEFFS1 ;Join processing 00003263 ;_ 00003264 ;---------------------------------------------------------------------* 00003265 .PAGE .SBTTL 'External Functions' ;00003266 .PSECT SNOBOL4_EXTERNAL,SHR,LONG ; 00003267 ; LOAD(P) 00003268 ; 00003269 LOAD: PROC , ;LOAD(P) 00003270 RCALL XPTR,VARVAL,,FAIL ;Get prototype 00003271 PUSH XPTR ;Save prototype 00003272 RCALL WPTR,VARVAL,,FAIL ;Get library name 00003273 LOCSP VSP,WPTR ;Get specifier for library 00003274 POP XPTR ;Restore prototypr 00003275 LOCSP XSP,XPTR ;Get specifier for prototype 00003276 STREAM YSP,XSP,VARATB,PROTER,PROTER ;00003277 ; Get function name from prototype 00003278 AEQLC STYPE,LPTYP,PROTER ;Verify left parenthesis 00003279 RCALL XPTR,GENVAR,YSPPTR ;Generate variable for function 00003280 RCALL ZCL,FINDEX,XPTR ;Find function 00003281 MOVD YCL,ZEROCL ;Set argument count to zero 00003282 LOAD4: FSHRTN XSP,1 ;Remove break character 00003283 STREAM ZSP,XSP,VARATB,LOAD1,PROTER ;00003284 ; Break out argument 00003285 SELBRA STYPE, ;00003286 ; Branch on break type 00003287 RCALL XPTR,GENVAR,ZSPPTR ;Generate variable for data type 00003288 LOCAPV XPTR,DTATL,XPTR,LOAD9 ;00003289 ; Look up data type 00003290 GETDC XPTR,XPTR,DESCR ;Extract data type code 00003291 PUSH XPTR ;Save data type code 00003292 LOAD10:INCRA YCL,1 ;Increment count of arguments 00003293 BRANCH LOAD4 ;Continue 00003294 ;_ 00003295 LOAD6: INCRA YCL,1 ;Count last argument 00003296 RCALL XPTR,GENVAR,ZSPPTR ;Generate variable for data type 00003297 LOCAPV XPTR,DTATL,XPTR,LOAD11 ;00003298 ; Look up data type 00003299 GETDC XPTR,XPTR,DESCR ;Get data type code 00003300 PUSH XPTR ;Save data type code 00003301 LOAD13:FSHRTN XSP,1 ;Delete right parenthesis 00003302 RCALL XPTR,GENVAR,XSPPTR ;Generate variable for target 00003303 LOCAPV XPTR,DTATL,XPTR,LOAD7 ;00003304 ; Look up data type 00003305 GETDC XPTR,XPTR,DESCR ;Get data type code 00003306 PUSH XPTR ;Save data type code 00003307 LOAD8: SETVA LODCL,YCL ;Insert number of arguments 00003308 INCRA YCL,1 ;Increment count 00003309 MULTC XCL,YCL,DESCR ;Convert to address units 00003310 INCRA XCL,DESCR ;Add space for entry point 00003311 SETVC XCL,B ;Insert BLOCK data type 00003312 RCALL XPTR,BLOCK,XCL ;Allocate block for definition 00003313 PUTDC ZCL,0,LODCL ;Insert procedure descriptor 00003314 PUTDC ZCL,DESCR,XPTR ;Insert definition block 00003315 SUM XPTR,XPTR,XCL ;Compute pointer to end of block 00003316 LOAD12:DECRA XPTR,DESCR ;Decrement pointer 00003317 POP YPTR ;Restore data type 00003318 PUTDC XPTR,DESCR,YPTR ;Insert in block 00003319 DECRA YCL,1 ;Decrement count 00003320 ACOMPC YCL,0,LOAD12 ;Check for end 00003321 LOAD YPTR,YSP,VSP,FAIL ;Load external function 00003322 PUTDC XPTR,0,YPTR ;Insert entry point 00003323 BRANCH RETNUL ;Return null string as value 00003324 ;_ 00003325 LOAD7: PUSH ZEROCL ;Save 0 for unspecified type 00003326 BRANCH LOAD8 ;Continue 00003327 ;_ 00003328 LOAD9: PUSH ZEROCL ;Save 0 for unspecified type 00003329 BRANCH LOAD10 ;Continue 00003330 ;_ 00003331 LOAD1: PUSH ZEROCL ;Save 0 for unspecified type 00003332 SETSP TSP,XSP ;Set up break check 00003333 SETLC TSP,1 ;Set length to 1 00003334 INCRA YCL,1 ;00003335 LEXCMP TSP,RPRNSP,LOAD4,LOAD13,LOAD4 ;00003336 ;_ 00003337 LOAD11:PUSH ZEROCL ;Save 0 for unspecified type 00003338 BRANCH LOAD13 ;Continue 00003339 ;_ 00003340 ;---------------------------------------------------------------------* 00003341 ; 00003342 ; UNLOAD(F) 00003343 ; 00003344 UNLOAD:PROC , ;UNLOAD(F) 00003345 RCALL XPTR,VARVAL,,FAIL ;Get function name 00003346 RCALL ZCL,FINDEX,XPTR ;Locate function descriptor 00003347 PUTDC ZCL,0,UNDFCL ;Undefine function 00003348 LOCSP XSP,XPTR ;Get specifier 00003349 UNLOAD XSP ;Unload external definition 00003350 BRANCH RETNUL ;Return 00003351 ;_ 00003352 ;---------------------------------------------------------------------* 00003353 ; 00003354 ; Linkage to External Functions 00003355 ; 00003356 LNKFNC:PROC , ;Procedure to link to externals 00003357 SETAV XCL,INCL ;Get actual number of arguments 00003358 MOVD YCL,INCL ;Save function descriptor 00003360 SETAV WCL,WCL ;E3.9.1 GETDC ZCL,YCL,DESCR ;Get definition block 00003361 PSTACK YPTR ;Post stack position 00003362 SETAC TCL,2*DESCR ;Set offset for first argument 00003363 LNKF1: PUSH ;00003364 ; Save working descriptors 00003365 RCALL XPTR,ARGVAL,,FAIL ;Evaluate argument 00003366 POP ;00003367 ; Restore working descriptors 00003368 DECRA WCL,1 ;E3.9.1 ACOMPC WCL,0,,,LNKF8 ;E3.9.1 LNKF7: GETD ZPTR,ZCL,TCL ;Get data type required 00003369 VEQLC ZPTR,0,,LNKF6 ;Check for possible conversion 00003370 VEQL ZPTR,XPTR,,LNKF6 ;Skip if data types the same 00003371 SETAV DTCL,XPTR ;Data type of argument 00003372 MOVV DTCL,ZPTR ;Data type required 00003373 DEQL DTCL,VIDTP,,LNKVI ;STRING-INTEGER 00003374 DEQL DTCL,IVDTP,,LNKIV ;INTEGER-STRING 00003375 DEQL DTCL,RIDTP,,LNKRI ;REAL-INTEGER 00003376 DEQL DTCL,IRDTP,,LNKIR ;INTEGER-REAL 00003377 DEQL DTCL,RVDTP,,LNKRV ;REAL-STRING 00003378 DEQL DTCL,VRDTP,INTR1,LNKVR ;00003379 ; STRING-REAL 00003380 LNKIV: RCALL XPTR,GNVARI,XPTR,LNKF6 ;00003381 ; Convert INTEGER to STRING 00003382 ;_ 00003383 LNKRI: RLINT XPTR,XPTR,INTR1,LNKF6 ;00003384 ; Convert REAL to INTEGER 00003385 ;_ 00003386 LNKIR: INTRL XPTR,XPTR ;Convert INTEGER to REAL 00003387 BRANCH LNKF6 ;00003388 ;_ 00003389 LNKVR: LOCSP XSP,XPTR ;Get specifier 00003390 SPCINT XPTR,XSP,,LNKIR ;Convert STRING to INTEGER 00003391 SPREAL XPTR,XSP,INTR1,LNKF6 ;00003392 ; Convert STRING to REAL 00003393 ;_ 00003394 LNKRV: REALST XSP,XPTR ;00003395 RCALL XPTR,GENVAR,XSPPTR,LNKF6 ;00003396 ;_ 00003397 LNKVI: LOCSP XSP,XPTR ;Get specifier 00003398 SPCINT XPTR,XSP,,LNKF6 ;Convert to INTEGER 00003399 SPREAL XPTR,XSP,INTR1,LNKRI ;00003400 ; Convert STRING to REAL 00003401 LNKF6: INCRA TCL,DESCR ;Increment offset 00003402 PUSH XPTR ;Save argument 00003403 LNKF8: DECRA XCL,1 ;E3.9.1 ACOMPC XCL,0,LNKF1 ;E3.9.1 GETDC WPTR,YCL,0 ;Get procedure descriptor 00003406 SETAV WPTR,WPTR ;Get argument count required 00003407 LNKF4: ACOMPC WCL,0,,LNKF5,LNKF5 ;E3.9.1 PUSH NULVCL ;E3.9.1 DECRA WCL,1 ;Decrement argument count 00003415 BRANCH LNKF4 ;Continue 00003416 ;_ 00003417 LNKF5: GETSIZ WCL,ZCL ;Get size of definition block 00003418 SUM XPTR,ZCL,WCL ;Compute pointer to end 00003419 GETDC ZPTR,XPTR,0 ;Get data target descriptor 00003420 GETDC ZCL,ZCL,DESCR ;Get function address 00003421 INCRA YPTR,2*DESCR ;Get pointer to argument list 00003422 LINK ZPTR,YPTR,WPTR,ZCL,FAIL ;00003423 ; Link to external function 00003424 VEQLC ZPTR,L,RTZPTR ;Check for linked string 00003425 GETSPC ZSP,ZPTR,0 ;Get specifier 00003426 BRANCH GENVRZ ;Go generate variable 00003427 ;_ 00003428 ;---------------------------------------------------------------------* 00003429 .PAGE .SBTTL 'Arrays, Tables, and Defined Data Objects' ;00003430 .PSECT SNOBOL4_DEFINED_DATA,SHR,LONG ; 00003431 ; ARRAY(P,V) 00003432 ; 00003433 ARRAY: PROC , ;ARRAY(P,V) 00003434 RCALL XPTR,VARVAL,,FAIL ;Get prototype 00003435 PUSH XPTR ;Save prototype 00003436 RCALL TPTR,ARGVAL,,FAIL ;Get initial value for array elements 00003437 POP XPTR ;Restore prototype 00003438 SETAC ARRMRK,0 ;Clear prototype analysis switch 00003439 MOVD WCL,ZEROCL ;Initialize dimensionality to zero 00003440 MOVD XCL,ONECL ;Initialize size to one 00003441 LOCSP XSP,XPTR ;Get specifier to prototype 00003442 PUSH XPTR ;Save prototype for later insertion 00003443 ARRAY1:STREAM YSP,XSP,NUMBTB,PROTER,ARROT1 ;E3.5.1 SPCINT YCL,YSP,PROTER ;Convert string to integer 00003446 SELBRA STYPE,<,ARRAY3> ;Branch on colon or comma 00003447 FSHRTN XSP,1 ;Delete colon 00003448 STREAM ZSP,XSP,NUMBTB,PROTER,ARROT2 ;00003449 SPCINT ZCL,ZSP,PROTER ;Convert upper bound to integer 00003450 SELBRA STYPE, ;00003451 ; Verify break character 00003452 ;_ 00003453 ARRAY3:ACOMPC YCL,0,,PROTER,PROTER ;00003454 ; Single number must be positive 00003455 MOVD ZCL,YCL ;Move to copy 00003456 SETAC YCL,1 ;Set lower bound to default of one 00003457 BRANCH ARRAY6 ;00003458 ;_ 00003459 ARRAY5:SUBTRT ZCL,ZCL,YCL ;Compute difference 00003460 SUM ZCL,ZCL,ONECL ;Add one 00003461 ACOMPC ZCL,0,,,PROTER ;00003462 ARRAY6:SETVA YCL,ZCL ;Insert width of dimension 00003463 PUSH YCL ;Save dimension information 00003464 MULT XCL,XCL,ZCL,PROTER ;Compute size of array to this point 00003465 INCRA WCL,1 ;Increase count of dimensions 00003466 AEQLC ARRMRK,0,ARRAY7 ;E3.5.1 FSHRTN XSP,1 ;Remove break character 00003467 BRANCH ARRAY1 ;00003468 ;_ 00003469 ARROT1:SETAC ARRMRK,1 ;On run out, mark end of prototype 00003470 SPCINT YCL,YSP,PROTER,ARRAY3 ;00003471 ; Convert string to integer 00003472 ;_ 00003473 ARROT2:SETAC ARRMRK,1 ;On run out, mark end of prototype 00003474 SPCINT ZCL,ZSP,PROTER,ARRAY5 ;00003475 ; Convert string to integer 00003476 ;_ 00003477 ARRAY7:SUM ZCL,XCL,WCL ;Add dimensionality to array size 00003478 INCRA ZCL,2 ;Add two for heading information 00003479 MULTC ZCL,ZCL,DESCR ;Convert to address units 00003480 SETVC ZCL,A ;Insert ARRAY data type 00003481 RCALL ZPTR,BLOCK,ZCL ;Allocate block for array structure 00003482 MOVD XPTR,ZPTR ;Save copy 00003483 SUM WPTR,XPTR,ZCL ;Get pointer to last descriptor 00003484 PUTDC ZPTR,2*DESCR,WCL ;Insert dimensionality 00003485 INCRA XPTR,DESCR ;Update working pointer 00003486 ARRAY8:INCRA XPTR,DESCR ;Update working pointer for another 00003487 POP YPTR ;Restore index pair 00003488 PUTDC XPTR,DESCR,YPTR ;Insert in structure 00003489 DECRA WCL,1 ;Decrement dimensionality 00003490 ACOMPC WCL,0,ARRAY8,ARRFIL;Check for last one 00003491 ARRAY9:PUTDC XPTR,DESCR,TPTR ;Insert initial value 00003492 ARRFIL:INCRA XPTR,DESCR ;Update working pointer 00003493 ACOMP XPTR,WPTR,INTR10,,ARRAY9 ;00003494 ; Check for end 00003495 POP WPTR ;RESTORE PROTOTYPE E3.10.1 PUTDC ZPTR,DESCR,WPTR ;RETURN POINTER TO ARRAY E3.10.1 BRANCH RTZPTR ;Return pointer to array structure 00003498 ;_ 00003499 ;---------------------------------------------------------------------* 00003500 ; 00003501 ; TABLE(N,M) 00003502 ; 00003503 ASSOC: PROC , ;TABLE(N,M) 00003504 RCALL XPTR,INTVAL,,FAIL ;Get table size 00003505 PUSH XPTR ;Save size 00003506 RCALL WPTR,INTVAL,,FAIL ;Get secondary allocation 00003507 MULT ZPTR,WPTR,DSCRTW,SIZERR ;E3.10.4 INCRA ZPTR,2*DESCR ;E3.10.4 ACOMP ZPTR,SIZLMT,SIZERR,SIZERR ;E3.10.4 POP XPTR ;Restore size 00003508 ACOMPC XPTR,0,ASSOC1,,LENERR ;00003509 SETAC XPTR,EXTSIZ ;00003510 ASSOC1:INCRA XPTR,1 ;E3.2.3 MULTC XPTR,XPTR,2*DESCR ;E3.2.3 ACOMPC WPTR,0,ASSOC4,,LENERR ;00003512 SETAC WPTR,EXTSIZ ;00003513 ASSOC4:INCRA WPTR,1 ;E3.2.3 MULTC WPTR,WPTR,2*DESCR ;E3.2.3 SETVC XPTR,T ;E3.2.3 ASSOCE:PROC ASSOC ;E3.2.3 RCALL ZPTR,BLOCK,XPTR ;E3.2.3 PUTD ZPTR,XPTR,ONECL ;E3.2.3 DECRA XPTR,DESCR ;E3.2.3 PUTD ZPTR,XPTR,WPTR ;E3.2.3 ASSOC2:DECRA XPTR,2*DESCR ;E3.2.3 PUTD ZPTR,XPTR,NULVCL ;E3.2.3 AEQLC XPTR,DESCR,ASSOC2,RTZPTR ;E3.2.3 ;_ 00003529 ;---------------------------------------------------------------------* 00003530 ; 00003531 ; DATA(P) 00003532 ; 00003533 DATDEF:PROC , ;DATA(P) 00003534 RCALL XPTR,VARVAL,,FAIL ;Get prototype 00003535 SETAC DATACL,0 ;Initialize prototype switch 00003536 LOCSP XSP,XPTR ;Get specifier 00003537 STREAM YSP,XSP,VARATB,PROTER,PROTER ;00003538 ; Break out data type name 00003539 AEQLC STYPE,LPTYP,PROTER ;Verify left parenthesis 00003540 RCALL XPTR,GENVAR, ;00003541 ; Generate variable for name 00003542 RCALL ZCL,FINDEX, ;Find function descriptor 00003543 INCRV DATSEG,1 ;Increment data type code 00003544 VEQLC DATSEG,DATSIZ,,INTR27 ;00003545 ; Check against limit 00003546 MOVD YCL,ZEROCL ;Initialize count of fields 00003547 RCALL DTATL,AUGATL, ;00003548 ; Augment data type pair list 00003549 PSTACK WPTR ;Post stack position 00003550 PUSH ;Save code and name 00003551 DATA3: FSHRTN XSP,1 ;Delete break character 00003552 AEQLC DATACL,0,DAT5 ;Check for prototype end 00003553 STREAM YSP,XSP,VARATB,PROTER,PROTER ;00003554 ; Break out field 00003555 SELBRA STYPE, ;00003556 DATA4: LEQLC YSP,0,,DATA3 ;Check for zero length 00003557 RCALL XPTR,GENVAR,YSPPTR ;Generate variable 00003558 PUSH XPTR ;Save field name 00003559 RCALL XCL,FINDEX, ;Find function descriptor for field 00003560 GETDC WCL,XCL,0 ;Get procedure descriptor 00003561 DEQL WCL,FLDCL,DAT6 ;Check for FIELD procedure 00003562 GETDC ZPTR,XCL,DESCR ;Get field definition block 00003563 MULTC TCL,YCL,DESCR ;00003564 RCALL ZPTR,AUGATL, ;00003565 DAT7: PUTDC XCL,DESCR,ZPTR ;Insert new definition block 00003566 INCRA YCL,1 ;00003567 BRANCH DATA3 ;Continue 00003568 ;_ 00003569 DATA6: SETAC DATACL,1 ;Note end of prototype analysis 00003570 BRANCH DATA4 ;Join field processing 00003571 ;_ 00003572 DAT5: LEQLC XSP,0,PROTER ;Verify prototype consumption 00003573 AEQLC YCL,0,,PROTER ;E3.1.2 SETVA DATCL,YCL ;Insert field count for data function 00003574 PUTDC ZCL,0,DATCL ;Insert new procedure descriptor 00003575 MULTC YCL,YCL,DESCR ;00003576 INCRA YCL,2*DESCR ;Add two for the number and name 00003577 MOVV YCL,DATSEG ;Insert defined data code 00003578 RCALL ZPTR,BLOCK,YCL ;Allocate definition block 00003579 INCRA WPTR,DESCR ;E3.0.3 MOVBLK ZPTR,WPTR,YCL ;Copy from stack into block 00003580 PUTDC ZCL,DESCR,ZPTR ;Insert definition block 00003581 BRANCH RETNUL ;Return null value 00003582 ;_ 00003583 DAT6: PUTDC XCL,0,FLDCL ;Insert FIELD procedure descriptor 00003584 RCALL ZPTR,BLOCK,TWOCL ;Allocate definition block 00003585 PUTDC ZPTR,DESCR,DATSEG ;Insert data type code 00003586 MULTC TCL,YCL,DESCR ;00003587 PUTDC ZPTR,2*DESCR,TCL ;00003588 BRANCH DAT7 ;Join processing 00003589 ;_ 00003590 ;---------------------------------------------------------------------* 00003591 ; 00003592 ; PROTOTYPE(A) 00003593 ; 00003594 PROTO: PROC , ;PROTOTYPE(A) 00003595 RCALL XPTR,ARGVAL,,FAIL ;Get argument 00003596 VEQLC XPTR,A,NONARY ;Verify ARRAY 00003597 GETDC ZPTR,XPTR,DESCR ;Get prototype 00003598 BRANCH RTZPTR ;Return 00003599 ;_ 00003600 ;---------------------------------------------------------------------* 00003601 ; 00003602 ; Array and Table References 00003603 ; 00003604 ITEM: PROC , ;Array or table reference 00003605 SETAV XCL,INCL ;Get argument count 00003606 DECRA XCL,1 ;Skip referenced object 00003607 PUSH XCL ;Save count 00003608 RCALL YCL,ARGVAL,,FAIL ;Get referenced object 00003609 POP XCL ;Restore count 00003610 VEQLC YCL,A,,ARYAD3 ;ARRAY is acceptable 00003611 VEQLC YCL,T,NONARY,ASSCR ;TABLE is acceptable 00003612 ARYAD3:MOVD WCL,XCL ;Save copy of argument count 00003613 ARYAD1:ACOMPC XCL,0,,ARYAD2,ARYAD2 ;00003614 ; Count down on arguments 00003615 PUSH ;Save 00003616 RCALL XPTR,INTVAL,,FAIL ;Get index 00003617 POP ;Restore saved descriptors 00003618 PUSH XPTR ;Save index 00003619 DECRA XCL,1 ;Decrement argument count 00003620 BRANCH ARYAD1 ;00003621 ;_ 00003622 ARYAD2:MOVD ZPTR,ZEROCL ;Initialize offset to zero 00003623 GETDC ZCL,YCL,2*DESCR ;Get number of dimensions 00003624 MULTC YPTR,ZCL,DESCR ;Convert to addressing units 00003625 SUM YPTR,YCL,YPTR ;Add base and offset 00003626 INCRA YPTR,2*DESCR ;Add two for heading 00003627 ARYAD7:ACOMP WCL,ZCL,ARGNER,ARYAD9 ;00003628 ; Compare given and required number 00003629 PUSH ZEROCL ;If too few, supply a zero 00003630 INCRA WCL,1 ;Increment and loop 00003631 BRANCH ARYAD7 ;00003632 ;_ 00003633 ARYAD9:INCRA YCL,2*DESCR ;00003634 GETDC WPTR,YCL,DESCR ;Get index pair 00003635 SETAV TPTR,WPTR ;Get extent of dimension 00003636 ARYA11:POP XPTR ;Get index value 00003637 SUBTRT XPTR,XPTR,WPTR ;Compute differnece from lower bound 00003638 ACOMPC XPTR,0,,,FAIL ;If less than zero, out of bounds 00003639 ACOMP XPTR,TPTR,FAIL,FAIL;If greater than extent, out of bound 00003640 SUM XPTR,ZPTR,XPTR ;Else add to evolving sum 00003641 DECRA ZCL,1 ;Decrement dimension count 00003642 ACOMPC ZCL,0,,ARYA12 ;Get out if done 00003643 INCRA YCL,DESCR ;Adjust bas pointer 00003644 GETDC WPTR,YCL,DESCR ;Get index pair 00003645 SETAV TPTR,WPTR ;Get extent of dimension 00003646 MULT ZPTR,XPTR,TPTR ;Multiply for next dimension 00003647 BRANCH ARYA11 ;Continue with next dimension 00003648 ;_ 00003649 ARYA12:MULTC XPTR,XPTR,DESCR ;Expand offset into addressing units 00003650 SUM XPTR,YPTR,XPTR ;Add to adjusted base 00003651 ARYA10:SETVC XPTR,N ;Insert NAME data type 00003652 BRANCH RTXNAM ;Return interior pointer 00003653 ;_ 00003654 ASSCR: AEQLC XCL,1,ARGNER ;Only one argument for tables 00003655 PUSH YCL ;Save pointer to object 00003656 RCALL YPTR,ARGVAL,,FAIL ;Evaluate argument 00003657 POP XPTR ;E3.2.3 ASSCR5:LOCAPV WPTR,XPTR,YPTR,,ASSCR4 ;E3.2.3 LOCAPV WPTR,XPTR,ZEROCL,ASSCR2 ;00003661 ; Look for item with null value 00003662 ASSCR4:MOVA XPTR,WPTR ;00003663 PUTDC XPTR,2*DESCR,YPTR ;E3.2.3 BRANCH ARYA10 ;Join array reference exit 00003665 ;_ 00003666 ASSCR2:GETSIZ TCL,XPTR ;E3.2.3 GETD ZPTR,XPTR,TCL ;E3.2.3 AEQLC ZPTR,1,,ASSCR3 ;E3.2.3 MOVD XPTR,ZPTR ;E3.2.3 BRANCH ASSCR5 ;E3.2.3 ;_ E3.2.3 ASSCR3:DECRA TCL,DESCR ;E3.2.3 GETD WPTR,XPTR,TCL ;E3.2.3 PUSH ;E3.2.3 MOVD XPTR,WPTR ;E3.2.3 RCALL ZPTR,ASSOCE,, ;E3.2.3 POP ;E3.2.3 SETVC ZPTR,B ;E3.2.3 INCRA TCL,DESCR ;E3.2.3 PUTD XPTR,TCL,ZPTR ;E3.2.3 PUTDC ZPTR,2*DESCR,YPTR ;E3.2.3 MOVD XPTR,ZPTR ;E3.2.3 BRANCH ARYA10 ;E3.2.3 ;_ 00003683 ;---------------------------------------------------------------------* 00003684 ; Defined Object Creation 00003685 ; 00003686 DEFDAT:PROC , ;Procedure to create defined objects 00003687 SETAV XCL,INCL ;Get given number of arguments 00003688 MOVD WCL,XCL ;Save a copy 00003689 MOVD YCL,INCL ;Save function descriptor 00003690 PSTACK YPTR ;Post stack position 00003691 DEFD1: INCRA OCICL,DESCR ;Increment offset 00003692 GETD XPTR,OCBSCL,OCICL ;Get object code descriptor 00003693 TESTF XPTR,FNC,,DEFDC ;Check for function 00003694 DEFD2: AEQLC INSW,0,,DEFD8 ;Check &INPUT 00003695 LOCAPV ZPTR,INATL,XPTR,DEFD8 ;00003696 ; Look for input association 00003697 GETDC ZPTR,ZPTR,DESCR ;Get association 00003698 PUSH ;Save relevant descriptors 00003699 RCALL XPTR,PUTIN,,FAIL ;00003700 POP ;Restore relevant descriptors 00003701 BRANCH DEFD3 ;Join main processing 00003702 ;_ 00003703 DEFD8: GETDC XPTR,XPTR,DESCR ;Get value 00003704 DEFD3: PUSH XPTR ;Save value 00003705 DECRA XCL,1 ;Decrement argument count 00003706 ACOMPC XCL,0,DEFD1,,INTR10;Check for end 00003707 GETDC XCL,YCL,0 ;Get procedure descriptor 00003708 SETAV XCL,XCL ;Get number of arguments expected 00003709 DEFD4: ACOMP WCL,XCL,DEFD5,DEFD5;Compare given with expected 00003710 PUSH NULVCL ;Save null for omitted argument 00003711 INCRA WCL,1 ;Increment count 00003712 BRANCH DEFD4 ;Continue 00003713 ;_ 00003714 DEFD5: GETDC WCL,YCL,DESCR ;Get definition block 00003715 MULTC XCL,XCL,DESCR ;00003716 MOVV XCL,WCL ;Insert data type code 00003717 RCALL ZPTR,BLOCK,XCL ;Allocate block for data object 00003718 INCRA YPTR,DESCR ;Adjust stack position 00003719 MOVBLK ZPTR,YPTR,XCL ;Move values into block 00003720 BRANCH RTZPTR ;Return new object 00003721 ;_ 00003722 DEFDC: PUSH ;Save relevant descriptors 00003723 RCALL XPTR,INVOKE,, ;00003724 POP ;Restore relevant descriptors 00003725 BRANCH DEFD3 ;Join main processing 00003726 ;_ 00003727 DEFDN: POP ;Restore relevant descriptors 00003728 BRANCH DEFD2 ;Join main processing 00003729 ;_ 00003730 ;---------------------------------------------------------------------* 00003731 ; 00003732 ; Fields of Defined Data Objects 00003733 ; 00003734 FIELD: PROC , ;Field function procedure 00003735 PUSH INCL ;Save function descriptor 00003736 RCALL XPTR,ARGVAL,,FAIL ;Get value 00003737 DEQL XPTR,NULVCL,,NONAME;Check for null value 00003738 POP YCL ;Restore function descriptor 00003739 VEQLC XPTR,I,FIELD1 ;Check for INTEGER 00003740 RCALL XPTR,GNVARI,XPTR ;Convert INTEGER to STRING 00003741 FIELD1:MOVV DT1CL,XPTR ;Set up data type 00003742 GETDC YPTR,YCL,DESCR ;Get definition block 00003743 LOCAPT ZCL,YPTR,DT1CL,INTR1 ;00003744 ; Look for data type offset 00003745 GETDC ZCL,ZCL,2*DESCR ;Get offset 00003746 SUM XPTR,XPTR,ZCL ;Compute field position 00003747 SETVC XPTR,N ;Insert NAME data type 00003748 BRANCH RTXNAM ;Return name 00003749 ;_ 00003750 ;---------------------------------------------------------------------* 00003751 .PAGE .SBTTL 'Input and Output' ;00003752 .PSECT SNOBOL4_IO,SHR,LONG ; 00003753 ; INPUT(V,U,L) 00003754 ; 00003755 READ: PROC , ;INPUT(V,U,L) 00003756 RCALL XPTR,IND,,FAIL ;Get variable 00003757 PUSH XPTR ;Save variable 00003758 RCALL YPTR,INTVAL,,FAIL ;Get unit 00003759 PUSH YPTR ;Save unit 00003760 RCALL ZPTR,INTVAL,,FAIL ;Get length 00003761 POP ;Restore unit and variable 00003762 ACOMPC YPTR,0,,READ5,UNTERR ;00003763 ; Check for defaulted unit 00003764 READ6: ACOMPC ZPTR,0,READ2,,LENERR ;00003765 ; Check for defaulted length 00003766 LOCAPT TPTR,INSATL,YPTR,READ4 ;00003767 ; Look for default length 00003768 READ3: LOCAPV ZPTR,INATL,XPTR,READ1 ;00003769 ; Look for existing association 00003770 PUTDC ZPTR,DESCR,TPTR ;Inset input block 00003771 BRANCH RETNUL ;Return 00003772 ;_ Add new association pair 00003773 READ1: RCALL INATL,AUGATL,,RETNUL ;00003774 ;_ 00003775 READ4: MOVD ZPTR,DFLSIZ ;Set standard default 00003776 READ2: RCALL TPTR,BLOCK,IOBLSZ ;Allocate block 00003777 PUTDC TPTR,DESCR,YPTR ;Insert unit 00003778 PUTDC TPTR,2*DESCR,ZPTR ;Insert format 00003779 BRANCH READ3 ;Rejoin processing 00003780 ;_ 00003781 READ5: SETAC YPTR,UNITI ;Set up default unit 00003782 BRANCH READ6 ;Join processing 00003783 ;_ 00003784 ;---------------------------------------------------------------------* 00003785 ; 00003786 ; OUTPUT(V,U,F) 00003787 ; 00003788 PRINT: PROC , ;OUTPUT(V,U,F) 00003789 RCALL XPTR,IND,,FAIL ;Get variable 00003790 PUSH XPTR ;Save variable 00003791 RCALL YPTR,INTVAL,,FAIL ;Get unit 00003792 PUSH YPTR ;Save unit 00003793 RCALL ZPTR,VARVAL,,FAIL ;Get format 00003794 POP ;Restore unit and variable 00003795 ACOMPC YPTR,0,,PRINT5,UNTERR ;00003796 PRINT6:AEQLC ZPTR,0,PRINT2 ;Check for defaulted format 00003797 LOCAPT TPTR,OTSATL,YPTR,PRINT4 ;00003798 ; Insert length 00003799 PRINT3:LOCAPV ZPTR,OUTATL,XPTR,PRINT1 ;00003800 ; Look for output association 00003801 PUTDC ZPTR,DESCR,TPTR ;Insert output block 00003802 BRANCH RETNUL ;Return 00003803 ;_ 00003804 PRINT1:RCALL OUTATL,AUGATL,,RETNUL ;00003805 ; Add new association pair 00003806 ;_ 00003807 PRINT4:MOVD ZPTR,DFLFST ;Set up standard default 00003808 PRINT2:RCALL TPTR,BLOCK,IOBLSZ ;Allocate block 00003809 PUTDC TPTR,DESCR,YPTR ;Insert unit 00003810 PUTDC TPTR,2*DESCR,ZPTR ;Insert format 00003811 BRANCH PRINT3 ;Rejoin processing 00003812 ;_ 00003813 PRINT5:SETAC YPTR,UNITO ;Set default unit 00003814 BRANCH PRINT6 ;Join processing 00003815 ;_ 00003816 ;---------------------------------------------------------------------* 00003817 ; 00003818 ; BACKSPACE(U), ENDFILE(U), and REWIND(U) 00003819 ; 00003820 BKSPCE:PROC , ;BACKSPACE(N) 00003821 SETAC SCL,1 ;Indicate backspace 00003822 BRANCH IOOP ;00003823 ;_ 00003824 ENFILE:PROC BKSPCE ;ENDFILE(N) 00003825 SETAC SCL,2 ;Indicate end of file 00003826 BRANCH IOOP ;00003827 ;_ 00003828 REWIND:PROC BKSPCE ;REWIND(N) 00003829 SETAC SCL,3 ;Indicate rewind 00003830 IOOP: PUSH SCL ;Push indicator 00003831 RCALL XCL,INTVAL,,FAIL ;Evaluate integer argument 00003832 ACOMPC XCL,0,,UNTERR,UNTERR ;00003833 ; Reject negative or zero 00003834 POP SCL ;Restore indicator 00003835 SELBRA SCL,<,EOP,ROP> ;Select operation 00003836 BKSPCE XCL ;Backspace unit 00003837 BRANCH RETNUL ;00003838 ;_ 00003839 EOP: ENFILE XCL ;End file unit 00003840 BRANCH RETNUL ;00003841 ;_ 00003842 ROP: REWIND XCL ;Rewind unit 00003843 BRANCH RETNUL ;00003844 ;_ 00003845 ;---------------------------------------------------------------------* 00003846 ; 00003847 ; DETACH(N) 00003848 ; 00003849 DETACH:PROC , ;DETACH(N) 00003850 RCALL XPTR,IND,,FAIL ;Get name of variable 00003851 LOCAPV ZPTR,INATL,XPTR,DTCH1 ;00003852 ; Look for input association 00003853 PUTDC ZPTR,DESCR,ZEROCL ;Delete association if there is one 00003854 PUTDC ZPTR,2*DESCR,ZEROCL;Clear association pointer also 00003855 DTCH1: LOCAPV ZPTR,OUTATL,XPTR,RETNUL ;00003856 ; Look for output association 00003857 PUTDC ZPTR,DESCR,ZEROCL ;Delete association is there is one 00003858 PUTDC ZPTR,2*DESCR,ZEROCL;Clear association pointer also 00003859 BRANCH RETNUL ;Return null value 00003860 ;_ 00003861 ;---------------------------------------------------------------------* 00003862 ; 00003863 ; Input Procedure 00003864 ; 00003865 PUTIN: PROC , ;Input procedure 00003866 POP ;Restore block and variable 00003867 GETDC IO3PTR,IO1PTR,DESCR;Get unit 00003868 GETDC IO1PTR,IO1PTR,2*DESCR ;00003869 ; Get length 00003870 RCALL IO4PTR,CONVAR, ;00003872 ; Get space for string 00003873 LOCSP IOSP,IO4PTR ;Get specifier 00003874 INCRA RSTAT,1 ;Increment count of reads 00003875 STREAD IOSP,IO3PTR,FAIL,COMP5 ;00003876 ; Perform read 00003877 AEQLC TRIMCL,0,,PUTIN1 ;Check &INPUT 00003878 TRIMSP IOSP,IOSP ;Trim string 00003879 GETLG IO1PTR,IOSP ;Get length 00003880 PUTIN1:ACOMP IO1PTR,MLENCL,INTR8 ;E3.9.2 VEQLC IO2PTR,K,,PUTIN3 ;CHECK FOR KEYWORD E3.10.2 RCALL IO1PTR,GNVARS,IO1PTR ;E3.9.2 ; Form variable for string 00003882 PUTIN2:PUTDC IO2PTR,DESCR,IO1PTR ;E3.10.2 RRTURN IO1PTR,2 ;Return value 00003884 PUTIN3:LOCSP XSP,IO1PTR ;E3.10.2 SPCINT IO1PTR,XSP,INTR1,PUTIN2 ;E3.10.2 ;_ 00003885 ;---------------------------------------------------------------------* 00003886 ; 00003887 ; Output Procedure 00003888 ; 00003889 PUTOUT:PROC , ;Output procedure 00003890 POP ;Restore block and value 00003891 VEQLC IO2PTR,S,,PUTV ;Is value STRING? 00003892 VEQLC IO2PTR,I,,PUTI ;Is value INTEGER? 00003893 RCALL IO2PTR,DTREP,IO2PTR;Get data type representation 00003894 GETSPC IOSP,IO2PTR,0 ;Get specifier 00003895 BRANCH PUTVU ;Join processing 00003896 ;_ 00003897 PUTV: LOCSP IOSP,IO2PTR ;Get specifier 00003898 PUTVU: STPRNT IOKEY,IO1PTR,IOSP ;Perform print 00003899 INCRA WSTAT,1 ;Increment count of writes 00003900 BRANCH RTN1 ;Return 00003901 ;_ 00003902 PUTI: INTSPC IOSP,IO2PTR ;Convert INTEGER to STRING 00003903 BRANCH PUTVU ;Rejoin processing 00003904 ;_ 00003905 ;---------------------------------------------------------------------* 00003906 .PAGE .SBTTL 'Tracing Procedures and Functions' ;00003907 .PSECT SNOBOL4_TRACING,SHR,LONG ; 00003908 ; TRACE(V,R,T,F) 00003909 ; 00003910 TRACE: PROC , ;TRACE(V,R,T,F) 00003911 RCALL XPTR,IND,,FAIL ;Get name of variable 00003912 PUSH XPTR ;Save name 00003913 RCALL YPTR,VARVAL,,FAIL ;Get trace type 00003914 PUSH YPTR ;Save type 00003915 RCALL WPTR,ARGVAL,,FAIL ;Get tag 00003916 PUSH WPTR ;Save tag 00003917 RCALL ZPTR,VARVAL,,FAIL ;Get trace function 00003918 POP ;Restore saved arguments 00003919 DEQL YPTR,NULVCL,TRAC5 ;Is type defaulted?? 00003920 MOVD YPTR,VALTRS ;Set up VALUE default 00003921 TRAC5: LOCAPV YPTR,TRATL,YPTR,TRAC1 ;00003922 ; Look for trace type 00003923 GETDC YPTR,YPTR,DESCR ;Get sub pair list 00003924 TRACEP:PROC TRACE ;Subentry for TRACE 00003925 GETDC TPTR,YPTR,DESCR ;Get default function 00003926 DEQL ZPTR,NULVCL,,TRAC2 ;Check for null 00003927 RCALL TPTR,FINDEX, ;Locate function descriptor 00003928 TRAC2: SETAC XSIZ,5*DESCR ;V3.7 SETVC XSIZ,C ;Insert CODE data type 00003930 RCALL XCL,BLOCK,XSIZ ;Allocate block for code 00003931 MOVBLK XCL,TRCBLK,XSIZ ;V3.7 SETVC TPTR,2 ;Set up 2 arguments 00003933 PUTDC XCL,1*DESCR,TPTR ;Insert function descriptor 00003934 PUTDC XCL,3*DESCR,XPTR ;Insert name to be traced 00003935 PUTDC XCL,5*DESCR,WPTR ;Insert tag 00003936 GETDC TPTR,YPTR,0 ;Make entry for proper attribute 00003937 AEQLC TPTR,0,,TRAC4 ;00003938 LOCAPT TPTR,TPTR,XPTR,TRAC3 ;00003939 ; Locate trace 00003940 PUTDC TPTR,2*DESCR,XCL ;Insert new code block 00003941 BRANCH RETNUL ;Return 00003942 ;_ 00003943 TRAC3: RCALL TPTR,AUGATL, ;00003944 ; Augment pair list for new entry 00003945 TRAC6: PUTDC YPTR,0,TPTR ;Link in new pair list 00003946 BRANCH RETNUL ;Return 00003947 ;_ 00003948 TRAC1: DEQL YPTR,FUNTCL,INTR30 ;Is type FUNCTION? 00003949 MOVD YPTR,TFNCLP ;Set up CALL trace 00003950 RCALL ,TRACEP,, ;00003951 ; Call subentry to do it 00003952 MOVD YPTR,TFNRLP ;Set up RETURN trace 00003953 BRANCH TRACEP ;Branch to subentry to do it 00003954 ;_ 00003955 TRAC4: RCALL TPTR,BLOCK,TWOCL ;Allocate new pair list 00003956 PUTDC TPTR,DESCR,XPTR ;Insert name to be traced 00003957 PUTDC TPTR,2*DESCR,XCL ;Insert pointer to pseudo-code 00003958 BRANCH TRAC6 ;00003959 ;_ 00003960 ;---------------------------------------------------------------------* 00003961 ; 00003962 ; STOPTR(N,T) 00003963 ; 00003964 STOPTR:PROC , ;STOPTR(T,R) 00003965 RCALL XPTR,IND,,FAIL ;Get name of variable 00003966 PUSH XPTR ;Save name 00003967 RCALL YPTR,VARVAL,,FAIL ;Get trace respect 00003968 POP XPTR ;00003969 DEQL YPTR,NULVCL,STOPT2 ;Check for defaulted respect 00003970 MOVD YPTR,VALTRS ;Set up VALUE as default 00003971 STOPT2:LOCAPV YPTR,TRATL,YPTR,STOPT1 ;00003972 ; Look for trace respect 00003973 GETDC YPTR,YPTR,DESCR ;Get pointer to trace list 00003974 STOPTP:PROC STOPTR ;Subentry for FUNCTION 00003975 GETDC YPTR,YPTR,0 ;Get trace list 00003976 LOCAPT YPTR,YPTR,XPTR,FAIL;Look for traced variable 00003977 PUTDC YPTR,DESCR,ZEROCL ;Zero the entry 00003978 PUTDC YPTR,2*DESCR,ZEROCL;Overwrite trace 00003979 BRANCH RETNUL ;Return 00003980 ;_ 00003981 STOPT1:DEQL YPTR,FUNTCL,INTR30 ;Check for FUNCTION 00003982 MOVD YPTR,TFNCLP ;Set up CALL 00003983 RCALL ,STOPTP,, ;00003984 ; Call subprocedure 00003985 MOVD YPTR,TFNRLP ;Set up RETURN 00003986 BRANCH STOPTP ;Branch to subentry 00003987 ;_ 00003988 ;---------------------------------------------------------------------* 00003989 ; 00003990 ; Call Tracing 00003991 ; 00003992 FENTR: PROC , ;Procedure to trace on CALL 00003993 RCALL WPTR,VARVAL,,FAIL ;Get argument 00003994 FENTR3:SETLC PROTSP,0 ;Clear specifier 00003995 APDSP PROTSP,TRSTSP ;Append trace message 00003996 INTSPC XSP,STNOCL ;Convert &STNO to string 00003997 APDSP PROTSP,XSP ;Append &STNO 00003998 APDSP PROTSP,COLSP ;Append colon 00003999 APDSP PROTSP,TRLVSP ;Append level message 00004000 INTSPC XSP,LVLCL ;Convert &FNCLEVEL to string 00004001 APDSP PROTSP,XSP ;Append &FNCLEVEL 00004002 APDSP PROTSP,TRCLSP ;Append call message 00004003 LOCSP XSP,WPTR ;Get specifier for argument 00004004 GETLG TCL,XSP ;Get length 00004005 ACOMPC TCL,BUFLEN,FXOVR,FXOVR ;00004006 ; Check for excessively long string 00004007 APDSP PROTSP,XSP ;Append function name 00004008 APDSP PROTSP,LPRNSP ;Append left parenthesis 00004009 SETAC WCL,0 ;Set argument count to 0 00004010 FNTRLP:INCRA WCL,1 ;Increment argument count 00004011 RCALL ZPTR,ARGINT,, ;00004012 ; Get argument 00004013 GETDC ZPTR,ZPTR,DESCR ;Get value 00004014 VEQLC ZPTR,S,,DEFTV ;Is it STRING? 00004015 VEQLC ZPTR,I,,DEFTI ;Is it INTEGER? 00004016 RCALL A2PTR,DTREP,ZPTR ;Get data type representation 00004017 GETSPC XSP,A2PTR,0 ;Get specifier 00004018 GETLG SCL,XSP ;Get length 00004019 SUM TCL,TCL,SCL ;Total length 00004020 ACOMPC TCL,BUFLEN,FXOVR,FXOVR ;00004021 ; Check for excessively long string 00004022 DEFTIA:APDSP PROTSP,XSP ;Append value 00004023 BRANCH DEFDTT ;Continue with next argument 00004024 ;_ 00004025 DEFTI: INTSPC XSP,ZPTR ;Convert INTEGER to STRING 00004026 BRANCH DEFTIA ;Rejoin processing 00004027 ;_ 00004028 DEFTV: LOCSP XSP,ZPTR ;Get specifier 00004029 GETLG SCL,XSP ;Get length 00004030 SUM TCL,TCL,SCL ;Get total length 00004031 ACOMPC TCL,BUFLEN,FXOVR,FXOVR ;00004032 ; Check for excessively long string 00004033 APDSP PROTSP,QTSP ;Append quote 00004034 APDSP PROTSP,XSP ;Append value 00004035 APDSP PROTSP,QTSP ;Append quote 00004036 DEFDTT:APDSP PROTSP,CMASP ;Append comma 00004037 BRANCH FNTRLP ;Continue processing 00004038 ;_ 00004039 FENTR4:AEQLC WCL,1,,FENTR5 ;Leave paren if no arguments 00004040 SHORTN PROTSP,1 ;Delete last comma 00004041 FENTR5:APDSP PROTSP,RPRNSP ;Append right parenthesis 00004042 MSTIME ZPTR ;Get time 00004043 SUBTRT ZPTR,ZPTR,ETMCL ;Compute elapsed time 00004044 INTSPC XSP,ZPTR ;Convert to STRING 00004045 APDSP PROTSP,ETIMSP ;Append time message 00004046 APDSP PROTSP,XSP ;Append time 00004047 STPRNT IOKEY,OUTBLK,PROTSP;Print trace message 00004048 BRANCH RTNUL3 ;Return 00004049 ;_ 00004050 FENTR2:PROC FENTR ;Standard entry 00004051 POP WPTR ;Restore function name 00004052 BRANCH FENTR3 ;00004053 ;_ 00004054 FXOVR: OUTPUT OUTPUT,PRTOVF ;Print error message 00004055 BRANCH RTNUL3 ;Return 00004056 ;_ 00004057 ;---------------------------------------------------------------------* 00004058 ; 00004059 ; Keyword and Label Tracing 00004060 ; 00004061 KEYTR: PROC , ;Procedure to trace keywords 00004062 SETAC FNVLCL,1 ;Set entry indicator 00004063 RCALL WPTR,VARVAL,,FAIL ;Get keyword 00004064 LOCSP XSP,WPTR ;Get specifier 00004065 RCALL YCL,KEYT,, ;00004066 ; Get value of keyword 00004067 KEYTR3:SETLC PROTSP,0 ;Clear specifier 00004068 APDSP PROTSP,TRSTSP ;Append trace message 00004069 INTSPC TSP,STNOCL ;Convert &STNO to string 00004070 APDSP PROTSP,TSP ;Append &STNO 00004071 APDSP PROTSP,COLSP ;Append colon 00004072 AEQLC FNVLCL,0,,KEYTR4 ;Check entry indicator 00004073 APDSP PROTSP,AMPSP ;Append ampersand 00004074 KEYTR4:APDSP PROTSP,XSP ;Append name of keyword 00004075 APDSP PROTSP,BLSP ;Append blank 00004076 AEQLC FNVLCL,0,,KEYTR5 ;Check entry indicator 00004077 INTSPC YSP,YCL ;Convert keyword value to string 00004078 APDSP PROTSP,EQLSP ;Append equal sign 00004079 KEYTR5:APDSP PROTSP,YSP ;Append value 00004080 MSTIME YPTR ;Get time 00004081 SUBTRT YPTR,YPTR,ETMCL ;Compute elapsed time 00004082 INTSPC XSP,YPTR ;Convert time to string 00004083 APDSP PROTSP,ETIMSP ;Append time message 00004084 APDSP PROTSP,XSP ;Append time 00004085 STPRNT IOKEY,OUTBLK,PROTSP;Print trace message 00004086 BRANCH RTN2 ;Return 00004087 ;_ 00004088 LABTR: PROC KEYTR ;Procedure to trace labels 00004089 SETAC FNVLCL,0 ;Set entry indicator 00004090 RCALL YPTR,VARVAL,,FAIL ;Get label name 00004091 LOCSP YSP,YPTR ;Get specifier 00004092 SETSP XSP,XFERSP ;Set up message specifier 00004093 BRANCH KEYTR3 ;Join common processing 00004094 ;_ 00004095 ;---------------------------------------------------------------------* 00004096 ; 00004097 ; Trace Handler 00004098 ; 00004099 TRPHND:PROC , ;Trace handling procedure 00004100 POP ATPTR ;Restore trace 00004101 DECRA TRAPCL,1 ;Decrement &TRACE 00004102 PUSH ;00004103 ; Save system descriptors 00004104 GETDC OCBSCL,ATPTR,2*DESCR ;NEW CODE BASE 00004105 ; Get new code base 00004106 SETAC OCICL,DESCR ;Set up offset 00004107 GETD XPTR,OCBSCL,OCICL ;Get function descriptor 00004108 SETAC TRAPCL,0 ;Set &TRACE to 0 00004109 SETAC TRACL,0 ;Set &FTRACE to 0 00004110 RCALL ,INVOKE,XPTR,<,> ;E3.3.1 ; Evaluate function 00004112 POP ;00004113 ; Restore system descriptors 00004114 BRANCH RTN1 ;E3.3.1 ;_ 00004116 ;---------------------------------------------------------------------* 00004121 ; 00004122 ; Value Tracing 00004123 ; 00004124 VALTR: PROC , ;Tracing procedures 00004125 SETAC FNVLCL,1 ;Note entry 00004126 VALTR2:RCALL XPTR,IND,,FAIL ;Get variable to be traced 00004127 PUSH XPTR ;Save name 00004128 RCALL ZPTR,VARVAL,,FAIL ;Get tag 00004129 POP XPTR ;Restore variable 00004130 VALTR4:SETLC TRACSP,0 ;Clear specifier 00004131 APDSP TRACSP,TRSTSP ;Append trace message 00004132 INTSPC XSP,STNOCL ;Convert &STNO to string 00004133 APDSP TRACSP,XSP ;Append &STNO 00004134 APDSP TRACSP,COLSP ;Append colon 00004135 AEQLC FNVLCL,0,,FNEXT1 ;Check entry indicator 00004136 VEQLC XPTR,S,DEFDT ;Is variable a string? 00004137 VALTR3:LOCSP XSP,XPTR ;Get specifier 00004138 GETLG TCL,XSP ;Get length 00004139 ACOMPC TCL,BUFLEN,VXOVR,VXOVR ;00004140 ; Check for excessively long name 00004141 VALTR1:APDSP TRACSP,XSP ;Append name of variable 00004142 APDSP TRACSP,BLEQSP ;Append ' = ' 00004143 GETDC YPTR,XPTR,DESCR ;Get value of traced variable 00004144 VEQLC YPTR,S,,TRV ;Is it STRING? 00004145 VEQLC YPTR,I,,TRI ;Is it INTEGER? 00004146 RCALL XPTR,DTREP,YPTR ;Else get data type representation 00004147 GETSPC XSP,XPTR,0 ;Get specifier 00004148 TRI2: APDSP TRACSP,XSP ;Append value 00004149 BRANCH TRPRT ;Join common processing 00004150 ;_ 00004151 TRV: LOCSP XSP,YPTR ;Get specifier 00004152 GETLG SCL,XSP ;Get length 00004153 SUM TCL,TCL,SCL ;Compute total length 00004154 ACOMPC TCL,BUFLEN,VXOVR,VXOVR ;00004155 ; Check for excessively long message 00004156 APDSP TRACSP,QTSP ;Append quote 00004157 APDSP TRACSP,XSP ;Append string 00004158 APDSP TRACSP,QTSP ;Append quote 00004159 TRPRT: MSTIME YPTR ;Get time 00004160 SUBTRT YPTR,YPTR,ETMCL ;Compute time in interpreter 00004161 INTSPC XSP,YPTR ;Convert to STRING 00004162 APDSP TRACSP,ETIMSP ;Append time message 00004163 APDSP TRACSP,XSP ;Append time 00004164 STPRNT IOKEY,OUTBLK,TRACSP;Print trace message 00004165 BRANCH RTNUL3 ;Return 00004166 ;_ 00004167 TRI: INTSPC XSP,YPTR ;Convert INTEGER to STRING 00004168 BRANCH TRI2 ;Join processing 00004169 ;_ 00004170 DEFDT: LOCSP XSP,ZPTR ;Get specifier for tag 00004171 BRANCH VALTR1 ;Join processing 00004172 ;_ 00004173 FNEXTR:PROC VALTR ;Return tracing procedure 00004174 SETAC FNVLCL,0 ;Note entry 00004175 BRANCH VALTR2 ;Join processing 00004176 ;_ 00004177 FNEXT1:APDSP TRACSP,TRLVSP ;Append level message 00004178 MOVD XCL,LVLCL ;Copy &FNCLEVEL 00004179 DECRA XCL,1 ;Decrement 00004180 INTSPC XSP,XCL ;Convert to STRING 00004181 APDSP TRACSP,XSP ;Append function level 00004182 APDSP TRACSP,BLSP ;Append blank 00004183 LOCSP XSP,RETPCL ;Get specifier for return 00004184 APDSP TRACSP,XSP ;Append return type 00004185 APDSP TRACSP,OFSP ;Append ' OF ' 00004186 DEQL RETPCL,FRETCL,VALTR3 ;00004187 ; Check for FRETURN 00004188 LOCSP XSP,XPTR ;Get specifier for function name 00004189 GETLG TCL,XSP ;Get length 00004190 ACOMPC TCL,BUFLEN,VXOVR,VXOVR ;00004191 ; Check for excessively long string 00004192 APDSP TRACSP,XSP ;Append name of function 00004193 BRANCH TRPRT ;Join common processing 00004194 ;_ FTRACE call trace 00004195 FNEXT2:PROC VALTR ;Note entry 00004196 SETAC FNVLCL,0 ;Restore function name 00004197 POP XPTR ;Join common processing 00004198 BRANCH VALTR4 ;00004199 ;_ 00004200 VXOVR: OUTPUT OUTPUT,PRTOVF ;Print error message 00004201 BRANCH RTNUL3 ;Return 00004202 ;_ 00004203 ;---------------------------------------------------------------------* 00004204 .PAGE .SBTTL 'Other Operations' ;00004205 .PSECT SNOBOL4_OTHER,SHR,LONG ; 00004206 ; Assignment 00004207 ; 00004208 ASGN: PROC , ;X = Y 00004209 INCRA OCICL,DESCR ;Increment offset in object code 00004210 GETD XPTR,OCBSCL,OCICL ;Get object code descriptor 00004211 TESTF XPTR,FNC,,ASGNC ;Test for function descriptor 00004212 ASGNV: VEQLC XPTR,K,,ASGNIC ;Check for keyword subject 00004213 INCRA OCICL,DESCR ;Increment offset in object code 00004214 GETD YPTR,OCBSCL,OCICL ;Get object code descriptor 00004215 TESTF YPTR,FNC,,ASGNCV ;Test for function descriptor 00004216 ASGNVN:AEQLC INSW,0,,ASGNV1 ;Check &INPUT 00004217 LOCAPV ZPTR,INATL,YPTR,ASGNV1 ;00004218 ; Look for input association 00004219 GETDC ZPTR,ZPTR,DESCR ;Get input association descriptor 00004220 RCALL YPTR,PUTIN,, ;00004221 ;_ 00004222 ASGNV1:GETDC YPTR,YPTR,DESCR ;Get value 00004223 ASGNVV:PUTDC XPTR,DESCR,YPTR ;Perform assignment 00004224 AEQLC OUTSW,0,,ASGN1 ;Check &OUTPUT 00004225 LOCAPV ZPTR,OUTATL,XPTR,ASGN1 ;00004226 ; Look for output association 00004227 GETDC ZPTR,ZPTR,DESCR ;Get output association descriptor 00004228 RCALL ,PUTOUT,;Perform output 00004229 ASGN1: ACOMPC TRAPCL,0,,RTNUL3,RTNUL3 ;00004230 ; Check &TRACE 00004231 LOCAPT ATPTR,TVALL,XPTR,RTNUL3 ;00004232 ; Look for VALUE trace 00004233 RCALL ,TRPHND,ATPTR,RTNUL3 ;E3.3.1 ;_ 00004235 ASGNC: RCALL XPTR,INVOKE,, ;00004236 ;_ 00004237 ASGNCV:PUSH XPTR ;Save subject of assignment 00004238 RCALL YPTR,INVOKE,, ;00004239 ASGNCJ:POP XPTR ;Restore subject 00004240 BRANCH ASGNVV ;00004241 ;_ 00004242 ASGNVP:POP XPTR ;Restore subject 00004243 BRANCH ASGNVN ;00004244 ;_ 00004245 ASGNIC:PUSH XPTR ;Save subject of assignment 00004246 RCALL YPTR,INTVAL,, ;00004247 ; Get integer value for keyword 00004248 ;_ 00004249 ;---------------------------------------------------------------------* 00004250 ; 00004251 ; X Y (concatenation) 00004252 ; 00004253 CON: PROC , ;X Y (concatenation) 00004254 RCALL ,XYARGS,,FAIL ;Get two arguments 00004255 DEQL XPTR,NULVCL,,RTYPTR;If first is null, return second 00004256 DEQL YPTR,NULVCL,,RTXPTR;If second is null, return first 00004257 VEQLC XPTR,S,,CON5 ;Is first STRING? 00004258 VEQLC XPTR,P,,CON5 ;Is first PATTERN? 00004259 VEQLC XPTR,I,,CON4I ;Is first INTEGER? 00004260 VEQLC XPTR,R,,CON4R ;Is first REAL? 00004261 VEQLC XPTR,E,INTR1 ;Is first EXPRESSION? 00004262 RCALL TPTR,BLOCK,STARSZ ;Allocate block for pattern 00004263 MOVBLK TPTR,STRPAT,STARSZ ;Set up pattern for expression 00004264 PUTDC TPTR,4*DESCR,XPTR ;Insert pointer to expression 00004265 MOVD XPTR,TPTR ;Set up as first argument 00004266 BRANCH CON5 ;00004267 ;_ 00004268 CON4R: REALST REALSP,XPTR ;Convert REAL to STRING 00004269 SETSP XSP,REALSP ;Set up specifier 00004270 RCALL XPTR,GENVAR,XSPPTR,CON5 ;00004271 ; Generate variable 00004272 ;_ 00004273 CON4I: INTSPC ZSP,XPTR ;Convert INTEGER to STRING 00004274 RCALL XPTR,GENVAR, ;00004275 ; Generate variable 00004276 CON5: VEQLC YPTR,S,,CON7 ;Is second STRING? 00004277 VEQLC YPTR,P,,CON7 ;Is second PATTERN? 00004278 VEQLC YPTR,I,,CON5I ;Is second INTEGER? 00004279 VEQLC YPTR,R,,CON5R ;Is second REAL? 00004280 VEQLC YPTR,E,INTR1 ;Is second EXPRESSION? 00004281 RCALL TPTR,BLOCK,STARSZ ;Allocate block for pattern 00004282 MOVBLK TPTR,STRPAT,STARSZ ;Set up pattern for expression 00004283 PUTDC TPTR,4*DESCR,YPTR ;Insert pointer to expression 00004284 MOVD YPTR,TPTR ;Set up as second argument 00004285 BRANCH CON7 ;Join processing 00004286 ;_ 00004287 CON5R: REALST REALSP,YPTR ;Convert REAL to STRING 00004288 SETSP YSP,REALSP ;Set up sepcifier 00004289 RCALL YPTR,GENVAR,YSPPTR,CON7 ;00004290 ; Generate variable 00004291 ;_ 00004292 CON5I: INTSPC ZSP,YPTR ;Convert INTEGER to STRING 00004293 RCALL YPTR,GENVAR, ;00004294 ; Generate variable 00004295 CON7: SETAV DTCL,XPTR ;Get data type of first 00004296 MOVV DTCL,YPTR ;Get data type of second 00004297 DEQL DTCL,VVDTP,,CONVV ;Check for STRING-STRING 00004298 DEQL DTCL,VPDTP,,CONVP ;Check for STRING-PATTERN 00004299 DEQL DTCL,PVDTP,,CONPV ;Check for PATTERN-STRING 00004300 DEQL DTCL,PPDTP,INTR1,CONPP ;00004301 ; Check for PATTERN-PATTERN 00004302 ;_ 00004303 CONVV: LOCSP XSP,XPTR ;Specifier for first string 00004304 LOCSP YSP,YPTR ;Specifier for second string 00004305 GETLG XCL,XSP ;Length of first string 00004306 GETLG YCL,YSP ;Length of second string 00004307 SUM XCL,XCL,YCL ;Total length 00004308 ACOMP XCL,MLENCL,INTR8 ;Check against &MAXLNGTH 00004309 RCALL ZPTR,CONVAR, ;Allocate space for string 00004310 LOCSP TSP,ZPTR ;Get specifier to allocated space 00004311 SETLC TSP,0 ;Clear length 00004312 APDSP TSP,XSP ;Move in first string 00004313 APDSP TSP,YSP ;Append second string 00004314 BRANCH GENVSZ ;Generate variable 00004315 ;_ 00004316 CONVP: LOCSP TSP,XPTR ;Specifier to string 00004317 GETLG TMVAL,TSP ;Get length of string 00004318 RCALL TPTR,BLOCK,LNODSZ ;Allocate block for pattern 00004319 MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR ;00004320 ; Construct pattern 00004321 CONPP: GETSIZ XSIZ,XPTR ;Get size of first pattern 00004322 GETSIZ YSIZ,YPTR ;Get size of second pattern 00004323 SUM TSIZ,XSIZ,YSIZ ;Compute total size required 00004324 SETVC TSIZ,P ;Insert PATTERN data type 00004325 RCALL TPTR,BLOCK,TSIZ ;Allocate block for new pattern 00004326 MOVD ZPTR,TPTR ;Save copy to return 00004327 LVALUE TVAL,YPTR ;Get least value for second pattern 00004328 CPYPAT TPTR,XPTR,TVAL,ZEROCL,XSIZ,XSIZ ;00004329 ; Copy in first pattern 00004330 CPYPAT TPTR,YPTR,ZEROCL,XSIZ,ZEROCL,YSIZ ;00004331 ; Copy in second pattern 00004332 BRANCH RTZPTR ;Return pattern as value 00004333 ;_ 00004334 CONPV: LOCSP TSP,YPTR ;Get specifier to string 00004335 GETLG TMVAL,TSP ;Get length of string 00004336 RCALL TPTR,BLOCK,LNODSZ ;Allocate block for pattern 00004337 MAKNOD YPTR,TPTR,TMVAL,ZEROCL,CHRCL,YPTR ;00004338 ; Construct pattern for string 00004339 BRANCH CONPP ;Join common processing 00004340 ;_ 00004341 ;---------------------------------------------------------------------* 00004342 ; 00004343 ; Indirect Reference 00004344 ; 00004345 IND: PROC , ;$X 00004346 RCALL XPTR,ARGVAL,,FAIL ;Get argument 00004347 VEQLC XPTR,S,,INDV ;STRING is acceptable 00004348 VEQLC XPTR,N,,RTXNAM ;NAME can be returned directly 00004349 VEQLC XPTR,I,,GENVIX ;Convert INTEGER 00004350 VEQLC XPTR,K,INTR1,RTXNAM;KEYWORD is like NAME 00004351 ;_ 00004352 INDV: AEQLC XPTR,0,RTXNAM,NONAME ;00004353 ; Be sure string is not null 00004354 ;_ 00004355 ;---------------------------------------------------------------------* 00004356 ; 00004357 ; Keywords 00004358 ; 00004359 KEYWRD:PROC , ;&X 00004360 INCRA OCICL,DESCR ;Increment offset 00004361 GETD XPTR,OCBSCL,OCICL ;Get object code descriptor 00004362 TESTF XPTR,FNC,,KEYC ;Check for function 00004363 KEYN: LOCAPV XPTR,KNATL,XPTR,KEYV ;00004364 ; Look up X on unprotected list 00004365 SETVC XPTR,K ;Set KEYWORD (NAME) data type 00004366 BRANCH RTXNAM ;Return by name 00004367 ;_ 00004368 KEYV: LOCAPV ATPTR,KVATL,XPTR,UNKNKW ;00004369 ; Look up X on protected list 00004370 GETDC ZPTR,ATPTR,DESCR ;Get value 00004371 BRANCH RTZPTR ;Return by value 00004372 ;_ 00004373 KEYC: RCALL XPTR,INVOKE,, ;00004374 ; Evaluate computed keyword 00004375 ;_ 00004376 KEYT: PROC KEYWRD ;Procedure to get keyword for trace 00004377 POP XPTR ;Restore argument 00004378 BRANCH KEYN ;00004379 ;_ Join common processing 00004380 ;---------------------------------------------------------------------* 00004381 ; Literal Evaluation 00004382 ; 00004383 ; 00004384 LIT: PROC , ;'X' 00004385 INCRA OCICL,DESCR ;Increment offset 00004386 GETD ZPTR,OCBSCL,OCICL ;Get object code descriptor 00004387 BRANCH RTZPTR ;Return value 00004388 ;_ 00004389 ;---------------------------------------------------------------------* 00004390 ; 00004391 ; Unary Name Operator 00004392 ; 00004393 NAME: PROC , ;.X 00004394 INCRA OCICL,DESCR ;Increment offset 00004395 GETD ZPTR,OCBSCL,OCICL ;Get object code descriptor 00004396 TESTF ZPTR,FNC,RTZPTR ;Test for function 00004397 RCALL ZPTR,INVOKE,ZPTR, ;00004398 ;_ 00004399 ; 00004400 ; 00004401 ;---------------------------------------------------------------------* 00004402 ; 00004403 ; Value Assignment in Pattern Matching 00004404 ; 00004405 NMD: PROC , ;00004406 MOVD TCL,NHEDCL ;00004407 NMD1: ACOMP TCL,NAMICL,INTR13,RTN2 ;00004408 ; Check for end 00004409 SUM TPTR,NBSPTR,TCL ;Compute address 00004410 GETSPC TSP,TPTR,DESCR ;Get specifier 00004411 GETDC TVAL,TPTR,DESCR+SPEC ;00004412 ; get variable 00004413 GETLG XCL,TSP ;Get length 00004414 ACOMP XCL,MLENCL,INTR8 ;Check &MAXLNGTH 00004415 VEQLC TVAL,E,,NAMEXN ;Is Variable EXPRESSION? 00004416 NMD5: VEQLC TVAL,K,,NMDIC ;Is variable KEYWORD? 00004417 RCALL VVAL,GENVAR, ;00004418 ; Generate string 00004419 NMD4: PUTDC TVAL,DESCR,VVAL ;Assign value 00004420 AEQLC OUTSW,0,,NMD3 ;Check &OUTPUT 00004421 LOCAPV ZPTR,OUTATL,TVAL,NMD3 ;00004422 ; Look for output association 00004423 GETDC ZPTR,ZPTR,DESCR ;Get association 00004424 RCALL ,PUTOUT,;Perform output 00004425 NMD3: ACOMPC TRAPCL,0,,NMD2,NMD2;Check &TRACE 00004426 LOCAPT ATPTR,TVALL,TVAL,NMD2 ;00004427 ; Look for VALUE trace 00004428 PUSH ;Save state 00004429 MOVD NHEDCL,NAMICL ;Set up new name list 00004430 RCALL ,TRPHND,ATPTR ;E3.3.1 ; Perform trace 00004432 POP ;Restore state 00004433 NMD2: INCRA TCL,DESCR+SPEC ;Move to next name 00004434 BRANCH NMD1 ;Continue 00004435 ;_ 00004436 NMDIC: SPCINT VVAL,TSP,INTR1,NMD4;Convert to INTEGER 00004437 ;_ 00004438 NAMEXN:RCALL TVAL,EXPEVL,TVAL, ;E3.10.5 ; Evaluate expression 00004440 ;_ 00004441 ;---------------------------------------------------------------------* 00004442 ; 00004443 ; Unevaluated Expression 00004444 ; 00004445 STR: PROC , ;*X 00004446 SUM ZPTR,OCBSCL,OCICL ;Compute position in code 00004447 RCALL ,CODSKP, ;Skip one nest 00004448 SETVC ZPTR,E ;Insert EXPRESSION data type 00004449 BRANCH RTZPTR ;Return pointer to code 00004450 ;_ 00004451 ;---------------------------------------------------------------------* 00004452 .PAGE .SBTTL 'Other Predicates' ;00004453 ; 00004454 ; DIFFER(X,Y) 00004455 ; 00004456 DIFFER:PROC , ;DIFFER(X,Y) 00004457 RCALL ,XYARGS,,FAIL ;Evaluate arguments 00004458 DEQL XPTR,YPTR,RETNUL,FAIL ;00004459 ; Compare them 00004460 ;_ 00004461 ;---------------------------------------------------------------------* 00004462 ; 00004463 ; IDENT(X,Y) 00004464 ; 00004465 IDENT: PROC , ;IDENT(X,Y) 00004466 RCALL ,XYARGS,,FAIL ;Evaluate arguments 00004467 DEQL XPTR,YPTR,FAIL,RETNUL ;00004468 ; Compare arguments 00004469 ;_ 00004470 ;---------------------------------------------------------------------* 00004471 ; 00004472 ; LGT(X,Y) 00004473 ; 00004474 LGT: PROC , ;LGT(X,Y) 00004475 RCALL XPTR,VARVAL,,FAIL ;Evaluate first argument 00004476 PUSH XPTR ;Save first argument 00004477 RCALL YPTR,VARVAL,,FAIL ;Evaluate second argument 00004478 POP XPTR ;Restore first argument 00004479 AEQLC XPTR,0,,FAIL ;Null is not greater than anything 00004480 AEQLC YPTR,0,,RETNUL ;Similarly for second argument 00004481 LOCSP XSP,XPTR ;Get specifier to first argument 00004482 LOCSP YSP,YPTR ;Get specifier to second argument 00004483 LEXCMP XSP,YSP,RETNUL,FAIL,FAIL ;00004484 ; Compare lexically 00004485 ;_ 00004486 ;---------------------------------------------------------------------* 00004487 ; 00004488 ; Unary Negation Operator 00004489 ; 00004490 NEG: PROC , ;\X 00004491 PUSH ;Save object code position 00004492 RCALL ,ARGVAL,,<,FAIL> ;Fail on success 00004493 POP ;Restore object code position 00004494 RCALL ,CODSKP,,RETNUL ;00004495 ; Skip argument and return 00004496 ;_ 00004497 ;---------------------------------------------------------------------* 00004498 ; 00004499 ; Unary Interrogation Operator 00004500 ; 00004501 QUES: PROC , ;?X 00004502 RCALL ,ARGVAL,, ;00004503 ; Evaluate argument 00004504 ;_ 00004505 ;---------------------------------------------------------------------* 00004506 .PAGE .SBTTL 'Other Functions' ;00004507 ; 00004508 ; APPLY(F,A\,...Ar) 00004509 ; 00004510 APPLY: PROC , ;APPLY(F,A\,...,Ar) 00004511 SETAV XCL,INCL ;Get count of arguments 00004512 DECRA XCL,1 ;Decrement to skip function name 00004513 ACOMPC XCL,1,,,ARGNER ;E3.3.3 PUSH XCL ;Save argument count 00004515 RCALL XPTR,VARVAL,,FAIL ;Get function name 00004516 POP XCL ;Restore argument count 00004517 LOCAPV XPTR,FNCPL,XPTR,UNDF ;00004518 ; Locate function 00004519 GETDC INCL,XPTR,DESCR ;Get function descriptor 00004520 SETVA INCL,XCL ;Insert actual number of arguments 00004521 RCALL ZPTR,INVOKE,, ;00004522 MOVD XPTR,ZPTR ;Return by name 00004523 BRANCH RTXNAM ;00004524 ;_ 00004525 ;---------------------------------------------------------------------* 00004526 ; 00004527 ; ARG(F,N), FIELD(F,N), and LOCAL(F,N) 00004528 ; 00004529 ARG: PROC , ;ARG(F,N) 00004530 PUSH ;Save ARG indicators 00004531 BRANCH ARG1 ;Join main processing 00004532 ;_ 00004533 ARGINT:PROC ARG ;Procedure used for CALL tracing 00004534 POP ;Restore arguments 00004535 PUSH ;Save indicators 00004536 BRANCH ARG2 ;Join processing 00004537 ;_ 00004538 LOCAL: PROC ARG ;LOCAL(F,N) 00004539 PUSH ;00004540 ; Save LOCAL indicators 00004541 BRANCH ARG1 ;Join main processing 00004542 ;_ 00004543 FIELDS:PROC ARG ;FIELD(F,N) 00004544 PUSH ;00004545 ; Save FIELD indicators 00004546 ARG1: RCALL XPTR,VARVAL,,FAIL ;Get function name 00004547 PUSH XPTR ;Save function name 00004548 RCALL XCL,INTVAL,,FAIL ;Get number 00004549 ACOMP ZEROCL,XCL,FAIL,FAIL ;00004550 ; Verify positive number 00004551 POP XPTR ;Restore function name 00004552 ARG2: LOCAPV XPTR,FNCPL,XPTR,INTR30 ;00004553 ; Look for function descriptor 00004554 GETDC XPTR,XPTR,DESCR ;Get function descriptor 00004555 GETDC YCL,XPTR,0 ;Get procedure descriptor 00004556 GETDC XPTR,XPTR,DESCR ;Get definition block 00004557 POP ;Restore indicators 00004558 AEQL YCL,ZCL,INTR30 ;Check procedure type 00004559 MULTC XCL,XCL,DESCR ;Convert number to address units 00004560 INCRA XCL,2*DESCR ;Skip prototype information 00004561 SETAV YCL,YCL ;Get argument count 00004562 MULTC YCL,YCL,DESCR ;Convert to address units 00004563 AEQLC ALCL,0,,ARG4 ;Check funcion type 00004564 INCRA YCL,2*DESCR ;Increment for heading 00004565 MOVD ZCL,YCL ;Get working copy 00004566 BRANCH ARG5 ;Branch to continue processing 00004567 ;_ 00004568 ARG4: GETSIZ ZCL,XPTR ;Get size of block 00004569 POP ALCL ;Restore entry indicator 00004570 AEQLC ALCL,0,,ARG5 ;Check entry type 00004571 SUM XCL,XCL,YCL ;Skip formal arguments 00004572 ARG5: ACOMP XCL,ZCL,FAIL ;Check number in bounds 00004573 GETD ZPTR,XPTR,XCL ;Get the desired name 00004574 BRANCH RTZPTR ;Return name as value 00004575 ;_ 00004576 ;---------------------------------------------------------------------* 00004577 ; 00004578 ; CLEAR() 00004579 ; 00004580 CLEAR: PROC , ;CLEAR() 00004581 RCALL ,ARGVAL,,FAIL ;Get rid of argument 00004582 SETAC DMPPTR,OBLIST-DESCR;Initialize bin pointer 00004583 CLEAR1:ACOMP DMPPTR,OBEND,RETNUL;Check for end 00004584 INCRA DMPPTR,DESCR ;Update for next bin 00004585 MOVD YPTR,DMPPTR ;Get working copy 00004586 CLEAR2:GETAC YPTR,YPTR,LNKFLD ;Get next variable 00004587 AEQLC YPTR,0,,CLEAR1 ;Check for end of chain 00004588 PUTDC YPTR,DESCR,NULVCL ;Assign null value 00004589 BRANCH CLEAR2 ;Continue 00004590 ;_ 00004591 ;---------------------------------------------------------------------* 00004592 ; 00004593 ; COLLECT(N) 00004594 ; 00004595 COLECT:PROC , ;COLLECT(N) 00004596 RCALL XPTR,INTVAL,,FAIL ;Get number of address units required 00004597 ACOMPC XPTR,0,,,LENERR ;Verify positive integer 00004598 RCALL ZPTR,GC,,FAIL;Call for storage regeneration 00004599 SETVC ZPTR,I ;Set INTEGER data type 00004600 BRANCH RTZPTR ;Return amount collected 00004601 ;_ 00004602 ;---------------------------------------------------------------------* 00004603 ; 00004604 ; COPY(X) 00004605 ; 00004606 COPY: PROC , ;COPY(X) 00004607 RCALL XPTR,ARGVAL,,FAIL ;Get object to copy 00004608 VEQLC XPTR,S,,INTR1 ;STRING cannot be copied 00004609 VEQLC XPTR,I,,INTR1 ;INTEGER cannot be copied 00004610 VEQLC XPTR,R,,INTR1 ;REAL cannot be copied 00004611 VEQLC XPTR,N,,INTR1 ;NAME cannot be copied 00004612 VEQLC XPTR,K,,INTR1 ;KEYWORD (NAME) cannot be copied 00004613 VEQLC XPTR,E,,INTR1 ;EXPRESSION cannot be copied 00004614 VEQLC XPTR,T,,INTR1 ;TABLE cannot be copied 00004615 GETSIZ XCL,XPTR ;Get size of object to copy 00004616 MOVV XCL,XPTR ;Insert data type 00004617 RCALL ZPTR,BLOCK,XCL ;Allocate block for copy 00004618 MOVBLK ZPTR,XPTR,XCL ;Copy contents 00004619 BRANCH RTZPTR ;Return the copy 00004620 ;_ 00004621 ;---------------------------------------------------------------------* 00004622 ; 00004623 ; CONVERT(X,T) 00004624 ; 00004625 CNVRT: PROC , ;CONVERT(X,T) 00004626 RCALL ZPTR,ARGVAL,,FAIL ;Get object to be converted 00004627 PUSH ZPTR ;Save object 00004628 RCALL YPTR,VARVAL,,FAIL ;Get data type target 00004629 POP ZPTR ;Restore object 00004630 LOCAPV XPTR,DTATL,YPTR,INTR1 ;00004631 ; Look for data type code 00004632 GETDC XPTR,XPTR,DESCR ;Get code 00004633 SETAV DTCL,ZPTR ;Insert object data type 00004634 MOVV DTCL,XPTR ;Insert target data type 00004635 DEQL DTCL,IVDTP,,CNVIV ;Check for INTEGER-STRING 00004636 DEQL DTCL,VCDTP,,RECOMP ;Check for STRING-CODE 00004637 DEQL DTCL,VEDTP,,CONVE ;00004638 DEQL DTCL,VRDTP,,CONVR ;Check for STRING-REAL 00004639 DEQL DTCL,RIDTP,,CONRI ;Check for REAL-INTEGER 00004640 DEQL DTCL,IRDTP,,CONIR ;Check for INTEGER-REAL 00004641 DEQL DTCL,VIDTP,,CNVVI ;CHeck for STRING-INTEGER 00004642 DEQL DTCL,ATDTP,,CNVAT ;Check for ARRAY-TABLE 00004643 DEQL DTCL,TADTP,,CNVTA ;Check for TABLE-ARRAY 00004644 VEQL ZPTR,XPTR,,RTZPTR ;E3.0.4 VEQLC XPTR,S,FAIL,CNVRTS ;E3.0.4 ; Check for idem-conversion 00004647 ;_ 00004648 RECOMP:SETAC SCL,1 ;Note STRING-CODE conversion 00004649 RECOMJ:LOCSP TEXTSP,ZPTR ;Set up global specifier 00004650 RECOMT:GETLG OCALIM,TEXTSP ;E3.1.5 AEQLC OCALIM,0,,RECOMN ;E3.1.5 MULTC OCALIM,OCALIM,DESCR;Convert to address units 00004653 INCRA OCALIM,6*DESCR ;Leave room for safety 00004654 SETVC OCALIM,C ;Insert CODE data type 00004655 RCALL CMBSCL,BLOCK,OCALIM;Allocate block for object code 00004656 SUM OCLIM,CMBSCL,OCALIM;Compute end 00004657 DECRA OCLIM,6*DESCR ;00004658 SETAC CMOFCL,0 ;Zero offset 00004659 SETAC ESAICL,0 ;Zero error count 00004660 PUSH CMBSCL ;Save block pointer 00004661 SELBRA SCL,<,CONVEX> ;Select correct procedure 00004662 RECOM1:LEQLC TEXTSP,0,,RECOM2 ;Is string exhausted? 00004663 RCALL ,CMPILE,, ;00004664 ; Compile statement 00004665 RECOM2:SETAC SCL,3 ;Set return switch 00004666 RECOMQ:INCRA CMOFCL,DESCR ;Increment offset 00004667 PUTD CMBSCL,CMOFCL,ENDCL;Insert END function 00004668 POP ZPTR ;Restore pointer to code block 00004669 RECOMZ:SUM CMBSCL,CMBSCL,CMOFCL ;00004670 ; Compute used portion of block 00004671 RCALL ,SPLIT, ;Split off remainder 00004672 SETAC OCLIM,0 ;Clear limit pointer 00004673 SETAC LPTR,0 ;Clear label pointer 00004674 ZERBLK COMREG,COMDCT ;Zero compiler descriptors 00004675 SELBRA SCL, ;00004676 ; Select return 00004677 ;_ 00004678 RECOMF:SETAC SCL,1 ;Set failure return 00004679 BRANCH RECOMQ ;Rejoin processing 00004680 ;_ 00004681 RECOMN:SETSP TEXTSP,BLSP ;E3.1.5 BRANCH RECOMT ;E3.1.5 ;_ E3.1.5 CODER: PROC CNVRT ;CODE(S) 00004682 RCALL ZPTR,VARVAL,, ;00004683 ; Get argument 00004684 ;_ 00004685 CONVE: PROC CNVRT ;Convert to EXPRESSION 00004686 SETAC SCL,2 ;Set switch 00004687 BRANCH RECOMJ ;Join common program 00004688 ;_ 00004689 CONVEX:RCALL FORMND,EXPR,,FAIL ;Compile expression 00004690 LEQLC TEXTSP,0,FAIL ;Verify complete compilation 00004691 RCALL ,TREPUB,FORMND ;Publish code tree 00004692 MOVD ZPTR,CMBSCL ;E3.1.6 SETVC ZPTR,E ;Insert EXPRESSION data type 00004694 SETAC SCL,3 ;Set return branch 00004695 BRANCH RECOMZ ;Join common program 00004696 ;_ 00004697 CONVR: LOCSP ZSP,ZPTR ;Get specifier 00004698 SPCINT ZPTR,ZSP,,CONIR ;Try conversion to INTEGER first 00004699 SPREAL ZPTR,ZSP,FAIL,RTZPTR ;00004700 ; Convert to REAL 00004701 ;_ 00004702 CONIR: INTRL ZPTR,ZPTR ;Convert INTEGER to REAL 00004703 BRANCH RTZPTR ;Return value 00004704 ;_ 00004705 CONRI: RLINT ZPTR,ZPTR,FAIL,RTZPTR ;00004706 ; Convert REAL to INTEGER 00004707 ;_ 00004708 CNVIV: RCALL ZPTR,GNVARI,ZPTR,RTZPTR ;00004709 ; Convert INTEGER to STRING 00004710 ;_ 00004711 CNVVI: LOCSP ZSP,ZPTR ;Get specifier 00004712 SPCINT ZPTR,ZSP,,RTZPTR ;Convert STRING to INTEGER 00004713 SPREAL ZPTR,ZSP,FAIL,CONRI;Try conversion to REAL 00004714 ;_ 00004715 CNVRTS:RCALL XPTR,DTREP,ZPTR ;Get data type representation 00004716 GETSPC ZSP,XPTR,0 ;Get specifier 00004717 BRANCH GENVRZ ;Go generate variable 00004718 ;_ 00004719 CNVTA: MOVD YPTR,ZPTR ;E3.2.3 MOVD YCL,ZEROCL ;E3.2.3 CNVTA7:GETSIZ XCL,YPTR ;E3.2.3 MOVD WPTR,YPTR ;E3.2.3 MOVD ZCL,XCL ;E3.2.3 DECRA XCL,3*DESCR ;E3.2.3 CNVTA1:GETD WCL,WPTR,XCL ;Get item value 00004724 DEQL WCL,NULVCL,,CNVTA2 ;Check for null value 00004725 INCRA YCL,1 ;Otherwise count item 00004726 CNVTA2:AEQLC XCL,DESCR,,CNVTA6 ;E3.2.3 DECRA XCL,2*DESCR ;Count down 00004728 BRANCH CNVTA1 ;Process next item 00004729 ;_ 00004730 CNVTA6:GETD YPTR,YPTR,ZCL ;E3.2.3 AEQLC YPTR,1,CNVTA7 ;E3.2.3 CNVTA4:AEQLC YCL,0,,FAIL ;Fail on empty table 00004731 MOVD WPTR,ZPTR ;E3.2.3 MULTC XCL,YCL,2*DESCR ;Convert count to address units 00004732 INTSPC YSP,YCL ;Get prototype for size 00004733 SETLC PROTSP,0 ;Clear specifier 00004734 APDSP PROTSP,YSP ;Append length 00004735 APDSP PROTSP,CMASP ;Append comma 00004736 MOVD WCL,ZEROCL ;E3.1.1 SETAC WCL,2 ;Set up 2 for second dimension 00004737 INTSPC XSP,WCL ;Convert to string 00004738 APDSP PROTSP,XSP ;Append 2 00004739 SETSP XSP,PROTSP ;Move specifier 00004740 RCALL TPTR,GENVAR,XSPPTR ;E3.5.2 ; Generate variable for prototype 00004742 MOVD ZCL,XCL ;Save size 00004743 INCRA XCL,4*DESCR ;Increment for heading 00004744 RCALL ZPTR,BLOCK,XCL ;Get block for array 00004745 SETVC ZPTR,A ;Insert ARRAY data type 00004746 MOVD ATPRCL,TPTR ;E3.5.2 SETVA ATEXCL,YCL ;Insert First dimension in head 00004747 MOVBLK ZPTR,ATRHD,FRDSCL ;Copy heading information 00004748 MOVD YPTR,ZPTR ;Save copy of block pointer 00004749 MULTC YCL,YCL,DESCR ;Convert item count to address units 00004750 INCRA YPTR,5*DESCR ;Skip heading 00004751 SUM TPTR,YPTR,YCL ;Compute second half position 00004752 CNVTA8:GETSIZ WCL,WPTR ;E3.2.3 DECRA WCL,2*DESCR ;E3.2.3 SUM WCL,WPTR,WCL ;E3.2.3 CNVTA3:GETDC TCL,WPTR,DESCR ;E3.2.3 DEQL TCL,NULVCL,,CNVTA5 ;E3.2.3 PUTDC TPTR,0,TCL ;E3.2.3 MOVDIC YPTR,0,WPTR,2*DESCR ;00004756 INCRA YPTR,DESCR ;Increment upper pointer 00004759 INCRA TPTR,DESCR ;Increment lower pointer 00004760 CNVTA5:INCRA WPTR,2*DESCR ;00004761 AEQL WCL,WPTR,CNVTA3 ;E3.2.3 GETDC WPTR,WCL,2*DESCR ;E3.2.3 AEQLC WPTR,1,CNVTA8 ;E3.8.1 SETAC TPTR,0 ;E3.8.1 BRANCH RTZPTR ;E3.8.1 ;_ 00004763 CNVAT: GETDC XCL,ZPTR,2*DESCR ;Get array dimensionality 00004764 MOVD YPTR,ZPTR ;Save copy of array pointer 00004765 AEQLC XCL,2,FAIL ;Verify rectangular array 00004766 GETDC XCL,ZPTR,3*DESCR ;Get second dimension 00004767 VEQLC XCL,2,FAIL ;Verify extent of 2 00004768 GETSIZ XCL,ZPTR ;Get size of array block 00004769 DECRA XCL,2*DESCR ;E3.2.3 RCALL XPTR,BLOCK,XCL ;Allocate block for pair list 00004771 SETVC XPTR,T ;E3.2.3 GETDC YCL,ZPTR,4*DESCR ;E3.2.3 MOVD ZPTR,XPTR ;E3.2.3 PUTD XPTR,XCL,ONECL ;E3.2.3 DECRA XCL,DESCR ;E3.2.3 MOVD TCL,EXTVAL ;E3.2.3 INCRA TCL,2*DESCR ;E3.2.3 PUTD XPTR,XCL,TCL ;E3.2.3 SETAV YCL,YCL ;E3.2.3 MULTC YCL,YCL,DESCR ;E3.2.3 INCRA YPTR,5*DESCR ;E3.2.3 SUM WPTR,YPTR,YCL ;E3.2.3 CNVAT2:MOVDIC XPTR,DESCR,WPTR,0 ;E3.2.3 MOVDIC XPTR,2*DESCR,YPTR,0 ;E3.2.3 DECRA YCL,DESCR ;E3.2.3 AEQLC YCL,0,,RTZPTR ;E3.2.3 INCRA XPTR,2*DESCR ;Increment pair list pointer 00004786 INCRA WPTR,DESCR ;Increment lower array pointer 00004787 INCRA YPTR,DESCR ;Increment upper array pointer 00004788 BRANCH CNVAT2 ;Continue 00004789 ;_ 00004790 ;---------------------------------------------------------------------* 00004791 ; 00004792 ; DATE() 00004793 ; 00004794 DATE: PROC , ;DATE() 00004795 RCALL ,ARGVAL,,FAIL ;Get rid of argument 00004796 DATE ZSP ;Get the date 00004797 BRANCH GENVRZ ;Go generate the variable 00004798 ;_ 00004799 ;---------------------------------------------------------------------* 00004800 ; 00004801 ; DATATYPE(X) 00004802 ; 00004803 DT: PROC , ;DATATYPE(X) 00004804 RCALL A2PTR,ARGVAL,,FAIL ;Get object 00004805 MOVV DT1CL,A2PTR ;Insert data type 00004806 LOCAPT A3PTR,DTATL,DT1CL,DTEXTN ;00004807 ; Look for data type 00004808 GETDC A3PTR,A3PTR,2*DESCR;Get data type name 00004809 DTRTN: RRTURN A3PTR,3 ;Return name 00004810 ;_ 00004811 DTEXTN:MOVD A3PTR,EXTPTR ;Set up EXTERNAL data type 00004812 BRANCH DTRTN ;Return 00004813 ;_ 00004814 ;---------------------------------------------------------------------* 00004815 ; 00004816 ; DUMP(N) 00004817 ; 00004818 DMP: PROC , ;DUMP(N) 00004819 RCALL XPTR,INTVAL,,FAIL ;Evaluate argument 00004820 AEQLC XPTR,0,,RETNUL ;No dump if zero 00004821 DUMP: PROC DMP ;End game dump procedure 00004822 SETAC WPTR,OBLIST-DESCR ;Initialize bin list pointer 00004823 DMPB: ACOMP WPTR,OBEND,RETNUL ;Check for end 00004824 INCRA WPTR,DESCR ;Increment pointer 00004825 MOVD YPTR,WPTR ;Save working copy 00004826 DMPA: GETAC YPTR,YPTR,LNKFLD ;Get string structure 00004827 AEQLC YPTR,0,,DMPB ;Check for end of chain 00004828 GETDC XPTR,YPTR,DESCR ;Get value 00004829 DEQL XPTR,NULVCL,,DMPA ;Skip null string values 00004830 SETLC DMPSP,0 ;Clear specifier 00004831 LOCSP YSP,YPTR ;Get specifier for variable 00004832 GETLG YCL,YSP ;Get length 00004833 ACOMPC YCL,BUFLEN,DMPOVR,DMPOVR ;00004834 ; Check for excessive length 00004835 APDSP DMPSP,YSP ;Append variable 00004836 APDSP DMPSP,BLEQSP ;Append ' = ' 00004837 VEQLC XPTR,S,,DMPV ;STRING is alright 00004838 VEQLC XPTR,I,,DMPI ;Convert INTEGER 00004839 RCALL A1PTR,DTREP,XPTR ;Else get representation 00004840 GETSPC YSP,A1PTR,0 ;Get specifier 00004841 DMPX: GETLG XCL,YSP ;Get length 00004842 SUM YCL,YCL,XCL ;Get total 00004843 ACOMPC YCL,BUFLEN,DMPOVR ;Check for excessive length 00004844 APDSP DMPSP,YSP ;Append value 00004845 BRANCH DMPRT ;Go print it 00004846 ;_ 00004847 DMPV: LOCSP YSP,XPTR ;Get specifier 00004848 GETLG XCL,YSP ;Get length 00004849 SUM YCL,YCL,XCL ;Total length 00004850 ACOMPC YCL,BUFLEN,DMPOVR ;Check for excessive length 00004851 APDSP DMPSP,QTSP ;Append quote 00004852 APDSP DMPSP,YSP ;Append value 00004853 APDSP DMPSP,QTSP ;Append quote 00004854 DMPRT: STPRNT IOKEY,OUTBLK,DMPSP ;Print line 00004855 BRANCH DMPA ;Continue 00004856 ;_ 00004857 DMPI: INTSPC YSP,XPTR ;Convert integer 00004858 BRANCH DMPX ;Rejoin processing 00004859 ;_ 00004860 DMPOVR:OUTPUT OUTPUT,PRTOVF ;Print error message 00004861 BRANCH DMPA ;Continue 00004862 ;_ 00004863 DMK: PROC , ;Procedure to dump keywords 00004864 OUTPUT OUTPUT,PKEYF ;Print caption 00004865 GETSIZ XCL,KNLIST ;Get size of pair list 00004866 DMPK1: GETD XPTR,KNLIST,XCL ;Get name of keyword 00004867 DECRA XCL,DESCR ;Adjust offset 00004868 GETD YPTR,KNLIST,XCL ;Get value of keyword 00004869 INTSPC YSP,YPTR ;Convert integer to string 00004870 LOCSP XSP,XPTR ;Get specifier 00004871 SETLC DMPSP,0 ;Clear specifier 00004872 APDSP DMPSP,AMPSP ;Append ampersand 00004873 APDSP DMPSP,XSP ;Append name 00004874 APDSP DMPSP,BLEQSP ;Append ' = ' 00004875 APDSP DMPSP,YSP ;Append value 00004876 STPRNT IOKEY,OUTBLK,DMPSP ;Print line 00004877 DECRA XCL,DESCR ;Adjust offset 00004878 AEQLC XCL,0,DMPK1,RTN1 ;Check for end 00004879 ;_ 00004880 ;---------------------------------------------------------------------* 00004881 ; 00004882 ; DUPL(S,N) 00004883 ; 00004884 DUPL: PROC , ;DUPL(S,N) 00004885 RCALL XPTR,VARVAL,,FAIL ;Get string to duplicate 00004886 PUSH XPTR ;Save string 00004887 RCALL YPTR,INTVAL,,FAIL ;Get duplication factor 00004888 POP XPTR ;Restore string 00004889 ACOMPC YPTR,0,,RETNUL,FAIL;Return null for 0 duplications 00004890 LOCSP XSP,XPTR ;Get specifier 00004891 GETLG XCL,XSP ;Get length 00004892 MULT XCL,XCL,YPTR,AERROR ;E3.9.3 ACOMP XCL,MLENCL,INTR8 ;Check &MAXLNGTH 00004894 RCALL ZPTR,CONVAR,XCL ;Allocate space for string 00004895 LOCSP TSP,ZPTR ;Get specifier 00004896 SETLC TSP,0 ;Zero length 00004897 DUPL1: APDSP TSP,XSP ;Append a copy 00004898 DECRA YPTR,1 ;Count down 00004899 AEQLC YPTR,0,DUPL1,GENVSZ;Check for end 00004900 ;_ 00004901 ;---------------------------------------------------------------------* 00004902 ; 00004903 ; OPSYN(F\,F\,N) 00004904 ; 00004905 OPSYN: PROC , ;OPSYN(F,G,N) 00004906 RCALL XPTR,VARVAL,,FAIL ;Get object function 00004907 PUSH XPTR ;Save object function 00004908 RCALL YPTR,VARVAL,,FAIL ;Get image function 00004909 PUSH YPTR ;Save image function 00004910 RCALL ZPTR,INTVAL,,FAIL ;Get type indicator 00004911 POP ;Restore image and object functions 00004912 AEQLC XPTR,0,,NONAME ;Object may not be null 00004913 AEQLC ZPTR,1,,UNYOP ;Check for unary definition 00004914 AEQLC ZPTR,2,,BNYOP ;Check for binary definition 00004915 AEQLC ZPTR,0,INTR30 ;Check for function definition 00004916 RCALL XPTR,FINDEX,XPTR ;Get function descriptor for object 00004917 UNBF: RCALL YPTR,FINDEX,YPTR ;E3.6.2 OPPD: MOVDIC XPTR,0,YPTR,0 ;Move procedure descriptor pair 00004921 MOVDIC XPTR,DESCR,YPTR,DESCR ;00004922 BRANCH RETNUL ;00004923 ;_ 00004924 UNYOP: LOCSP XSP,XPTR ;Get specifier for image 00004925 LEQLC XSP,1,UNAF ;Length must be 1 for operator 00004926 SETSP ZSP,PROTSP ;E3.5.3 SETLC ZSP,0 ;E3.5.3 APDSP ZSP,XSP ;E3.5.3 APDSP ZSP,LPRNSP ;E3.5.3 STREAM TSP,ZSP,UNOPTB,UNAF,UNAF ;E3.5.3 MOVD XPTR,STYPE ;STYPE has function descriptor 00004931 UNCF: LOCSP YSP,YPTR ;Get specifier for image 00004932 LEQLC YSP,1,UNBF ;Length must be 1 for operator 00004933 SETSP ZSP,PROTSP ;E3.5.3 SETLC ZSP,0 ;E3.5.3 APDSP ZSP,YSP ;E3.5.3 APDSP ZSP,LPRNSP ;E3.5.3 STREAM TSP,ZSP,UNOPTB,UNBF,UNBF ;E3.5.3 MOVD YPTR,STYPE ;STYPE has function descriptor 00004938 BRANCH OPPD ;Join to copy descriptors 00004939 ;_ 00004940 UNAF: RCALL XPTR,FINDEX,XPTR ;Find definition of image 00004941 BRANCH UNCF ;Join search for object 00004942 ;_ 00004943 BNYOP: LOCSP XSP,XPTR ;Get specifier for image 00004944 LCOMP XSP,EQLSP,BNAF ;Length must be 2 or less 00004945 SETSP ZSP,PROTSP ;E3.5.3 SETLC ZSP,0 ;E3.5.3 APDSP ZSP,XSP ;E3.5.3 APDSP ZSP,BLSP ;E3.5.3 STREAM TSP,ZSP,BIOPTB,BNAF,BNAF ;E3.5.3 LEQLC ZSP,0,BNAF ;E3.5.3 MOVD XPTR,STYPE ;STYPE has function descriptor 00004951 BNCF: LOCSP YSP,YPTR ;Get specifier for object 00004952 LCOMP YSP,EQLSP,BNBF ;Length must be 2 or less 00004953 SETSP ZSP,PROTSP ;E3.5.3 SETLC ZSP,0 ;E3.5.3 APDSP ZSP,YSP ;E3.5.3 APDSP ZSP,BLSP ;E3.5.3 STREAM TSP,ZSP,BIOPTB,BNBF,BNBF ;E3.5.3 LEQLC ZSP,0,BNBF ;E3.5.3 MOVD YPTR,STYPE ;STYPE has function descriptor 00004959 BRANCH OPPD ;Join to copy descriptors 00004960 ;_ 00004961 BNAF: LEXCMP XSP,BLSP,,BNCN ;Check for concatenation 00004962 RCALL XPTR,FINDEX,XPTR ;Find definition of image 00004963 BRANCH BNCF ;Join search for object 00004964 ;_ 00004965 BNCN: MOVD XPTR,CONCL ;CONCL represents concatenation 00004966 BRANCH BNCF ;Join search for object 00004967 ;_ 00004968 BNBF: LEXCMP YSP,BLSP,UNBF,,UNBF;Check for concatenation 00004969 MOVD YPTR,CONCL ;CONCL represents concatenation 00004970 BRANCH OPPD ;Join to copy descriptors 00004971 ;_ 00004972 ;---------------------------------------------------------------------* 00004973 ; 00004974 ; REPLACE(S\,S\,S\) 00004975 ; 00004976 RPLACE:PROC , ;REPLACE(S\,S\,S\) 00004977 RCALL XPTR,VARVAL,,FAIL ;Get first argument 00004978 PUSH XPTR ;Save first argument 00004979 RCALL YPTR,VARVAL,,FAIL ;Get second argument 00004980 PUSH YPTR ;Save second argument 00004981 RCALL ZPTR,VARVAL,,FAIL ;Get third argument 00004982 POP ;Restore first and second 00004983 AEQLC XPTR,0,,RTXPTR ;Ignore replacement on null 00004984 LOCSP YSP,YPTR ;Get specifier for second 00004985 LOCSP ZSP,ZPTR ;Get specifier for third 00004986 LCOMP ZSP,YSP,FAIL,,FAIL ;Verify same lengths 00004987 AEQLC YPTR,0,,FAIL ;Ignore null replacement 00004988 LOCSP XSP,XPTR ;Get specifier for first 00004989 GETLG XCL,XSP ;Get length 00004990 RCALL ZPTR,CONVAR,XCL ;Allocate space for result 00004991 LOCSP TSP,ZPTR ;Get specifier 00004992 SETLC TSP,0 ;Clear specifier 00004993 APDSP TSP,XSP ;Append first argument 00004994 RPLACE TSP,YSP,ZSP ;Perform replacement 00004995 BRANCH GENVSZ ;Got generate variable 00004996 ;_ 00004997 ;---------------------------------------------------------------------* 00004998 ; 00004999 ; SIZE(S) 00005000 ; 00005001 SIZE: PROC , ;SIZE(S) 00005002 RCALL XPTR,VARVAL,,FAIL ;Get argument 00005003 LOCSP XSP,XPTR ;Get specifier 00005004 GETLG ZPTR,XSP ;Get length 00005005 SETVC ZPTR,I ;Insert INTEGER data type 00005006 BRANCH RTZPTR ;Return length 00005007 ;_ 00005008 ;---------------------------------------------------------------------* 00005009 ; 00005010 ; TIME() 00005011 ; 00005012 TIME: PROC , ;TIME() 00005013 RCALL ,ARGVAL,,FAIL ;Get rid of argument 00005014 MSTIME ZPTR ;Get elapsed time 00005015 SUBTRT ZPTR,ZPTR,ETMCL ;Compute time in interpreter 00005016 SETVC ZPTR,I ;Insert INTEGER data type 00005017 BRANCH RTZPTR ;Return time 00005018 ;_ 00005019 ;---------------------------------------------------------------------* 00005020 ; 00005021 ; TRIM(S) 00005022 ; 00005023 TRIM: PROC , ;TRIM(S) 00005024 RCALL XPTR,VARVAL,,FAIL ;Get string 00005025 LOCSP ZSP,XPTR ;Get specifier 00005026 TRIMSP ZSP,ZSP ;Trim string 00005027 BRANCH GENVRZ ;Generate new variable 00005028 ;_ 00005029 ;---------------------------------------------------------------------* 00005030 .PAGE .SBTTL 'Common Code' ;00005031 .PSECT SNOBOL4_COMMON_CODE,SHR,LONG DATA: LHERE , ;00005032 RT1NUL:RRTURN NULVCL,1 ;Return null string by exit 1 00005033 ;_ 00005034 RTN1: LHERE , ;00005035 FAIL: RRTURN ,1 ;Return by exit 1 00005036 ;_ 00005037 RETNUL:RRTURN NULVCL,3 ;Return null string by exit 3 00005038 ;_ 00005039 RTN2: RRTURN ,2 ;Return by exit 2 00005040 ;_ 00005041 RTN3: LHERE , ;00005042 RTNUL3:RRTURN ,3 ;Return by exit 3 00005043 ;_ 00005044 RTXNAM:RRTURN XPTR,2 ;Return XPTR by exit 2 00005045 ;_ 00005046 RTXPTR:RRTURN XPTR,3 ;Return XPTR by exit 3 00005047 ;_ 00005048 RTYPTR:RRTURN YPTR,3 ;Return YPTR by exit 3 00005049 ;_ 00005050 ARTN: INCRA ARTHCL,1 ;Increment count of arithmetic 00005051 RTZPTR:RRTURN ZPTR,3 ;Return ZPTR by exit 3 00005052 ;_ 00005053 A5RTN: RRTURN A5PTR,1 ;Return A5PTR by exit 1 00005054 ;_ 00005055 TSALF: BRANCH SALF,SCNR ;Branch to SALF in scanner 00005056 ;_ 00005057 TSALT: BRANCH SALT,SCNR ;Branch to SALT in scanner 00005058 ;_ 00005059 TSCOK: BRANCH SCOK,SCNR ;Branch to SCOK in scanner 00005060 ;_ 00005061 GENVSZ:RCALL ZPTR,GNVARS,XCL,RTZPTR ;00005062 ; Generate variable from storage 00005063 ;_ 00005064 GENVRZ:RCALL ZPTR,GENVAR,ZSPPTR,RTZPTR ;00005065 ; Generate variable 00005066 ;_ 00005067 GENVIX:RCALL XPTR,GNVARI,XPTR,RTXNAM ;00005068 ; Generate variable from integer 00005069 ;_ 00005070 .PAGE .SBTTL 'Termination' ;00005071 .PSECT SNOBOL4_TERMINATION,SHR,LONG END: OUTPUT OUTPUT,NRMEND, ;00005072 ; End procedure 00005073 OUTPUT OUTPUT,LASTSF, ;00005074 ; Print status 00005075 BRANCH FTLEN2 ;Join termination procedure 00005076 ;_ 00005077 FTLEND:OUTPUT OUTPUT,FTLCF, ;V3.7 AEQLC INICOM,0,FTLEN3 ;BE SURE OF INITIALIZATION E3.10.6 OUTPUT OUTPUT,ALOCFL ;WARN USER E3.10.6 BRANCH ENDALL ;GET OUT E3.10.6 ;_ E3.10.6 FTLEN3:MULTC YCL,ERRTYP,DESCR ;E3.10.6 GETD YCL,MSGNO,YCL ;Get message pointer 00005082 GETSPC TSP,YCL,0 ;Get message specifier 00005083 STPRNT IOKEY,OUTBLK,TSP ;Print error message 00005084 FTLEN2:ISTACK , ;Reset system stack 00005085 AEQLC ETMCL,0,FTLEN4 ;Was compiler done? 00005086 MSTIME ETMCL ;Time out compiler 00005087 SUBTRT TIMECL,ETMCL,TIMECL;Compute time in compiler 00005088 SETAC ETMCL,0 ;Set interpreter time to 0 00005089 BRANCH FTLEN1 ;Join end game 00005090 ;_ 00005091 FTLEN4:MSTIME XCL ;Time out interpreter 00005092 SUBTRT ETMCL,XCL,ETMCL ;Compute time in interpreter 00005093 FTLEN1:AEQLC DMPCL,0,,END1 ;Check &DUMP 00005094 AEQLC NODPCL,0,DMPNO ;Check storage condition 00005095 ORDVST , ;Order string structures 00005096 OUTPUT OUTPUT,STDMP ;Print dump title 00005097 OUTPUT OUTPUT,NVARF ;Print subtitle 00005098 RCALL ,DUMP,, ;00005099 ; Dump natural variables 00005100 ;_ 00005101 DMPNO: OUTPUT OUTPUT,INCGCF ;Print disclaimer 00005102 OUTPUT OUTPUT,NODMPF ;Print reason 00005103 BRANCH END1 ;Join end game 00005104 ;_ 00005105 DMPK: RCALL ,DMK ;Dump keywords 00005106 END1: OUTPUT OUTPUT,STATHD ;Print statistics title 00005107 OUTPUT OUTPUT,CMTIME, ;00005108 ; Print compilation time 00005109 OUTPUT OUTPUT,INTIME, ;00005110 ; Print interpretation time 00005111 OUTPUT OUTPUT,EXNO, ;00005112 ; Print execution stats 00005113 OUTPUT OUTPUT,ARTHNO, ;00005114 ; Print arithmetic stats 00005115 OUTPUT OUTPUT,SCANNO, ;00005116 ; Print scanner stats 00005117 OUTPUT OUTPUT,STGENO, ;00005118 ; Print regeneration stats 00005119 OUTPUT OUTPUT,READNO, ;00005120 ; Print read stats 00005121 OUTPUT OUTPUT,WRITNO, ;00005122 ; Print write stats 00005123 AEQLC EXNOCL,0,END2 ;Check for no interpretation 00005124 INTRL FCL,ZEROCL ;00005125 BRANCH AVTIME ;Join end game 00005126 ;_ 00005127 END2: INTRL EXNOCL,EXNOCL ;Convert execution total to REAL 00005128 INTRL XCL,ETMCL ;Convert execution time to REAL 00005129 DVREAL FCL,XCL,EXNOCL ;Compute average time 00005130 AVTIME:OUTPUT OUTPUT,TIMEPS,;Print average time 00005131 ENDALL:ENDEX ABNDCL ;E3.2.2 ;_ 00005133 SYSCUT:OUTPUT OUTPUT,SYSCMT, ;00005134 ; System cut exit 00005135 AEQLC CUTNO,0,ENDALL ;E3.2.2 SETAC CUTNO,1 ;E3.2.2 BRANCH FTLEN2 ;Join end game 00005136 ;_ 00005137 ;---------------------------------------------------------------------* 00005138 .PAGE .SBTTL 'Error Handling' ;00005139 AERROR:SETAC ERRTYP,2 ;Arithmetic error 00005140 BRANCH FTLTST ;00005141 ;_ 00005142 ALOC2: SETAC ERRTYP,20 ;Storage exhausted 00005143 BRANCH FTLEND ;00005144 ;_ 00005145 ARGNER:SETAC ERRTYP,25 ;Incorrect number of arguments 00005146 BRANCH FTLEND ;00005147 ;_ 00005148 INTR10:LHERE , ;00005149 INTR13:LHERE , ;00005150 COMP3: SETAC ERRTYP,17 ;Program error 00005151 BRANCH FTLEND ;00005152 ;_ 00005153 COMP5: SETAC ERRTYP,11 ;Reading error 00005154 BRANCH FTLTST ;00005155 ;_ 00005156 COMP7: SETAC ERRTYP,27 ;Erroneous end statement 00005157 BRANCH FTLEND ;00005158 ;_ 00005159 COMP9: SETAC ERRTYP,26 ;Compilation error limit 00005160 DECRA ESAICL,DESCR ;Decrement error count 00005161 BRANCH FTLEND ;00005162 ;_ 00005163 EROR: SETAC ERRTYP,28 ;Erroneous statement 00005164 INCRA OCICL,DESCR ;Increment offset 00005165 GETD STNOCL,OCBSCL,OCICL;Get statement number 00005166 BRANCH FTLEND ;00005167 ;_ 00005168 EXEX: SETAC ERRTYP,22 ;Exceeded &STLIMIT 00005169 BRANCH FTLEND ;00005170 ;_ 00005171 INTR1: SETAC ERRTYP,1 ;Illegal data type 00005172 BRANCH FTLTST ;00005173 ;_ 00005174 INTR4: SETAC ERRTYP,24 ;Erroneous goto 00005175 BRANCH FTLEND ;00005176 ;_ 00005177 INTR5: SETAC ERRTYP,19 ;Failure in goto 00005178 BRANCH FTLEND ;00005179 ;_ 00005180 INTR8: SETAC ERRTYP,15 ;Exceeded &MAXLNGTH 00005181 BRANCH FTLTST ;00005182 ;_ 00005183 INTR27:SETAC ERRTYP,13 ;Excessive data types 00005184 BRANCH FTLTST ;00005185 ;_ 00005186 INTR30:SETAC ERRTYP,10 ;Illegal argument 00005187 BRANCH FTLTST ;00005188 ;_ 00005189 INTR31:SETAC ERRTYP,16 ;Overflow in pattern matching 00005190 SETAC SCERCL,3 ;00005191 BRANCH FTERST ;00005192 ;_ 00005193 LENERR:SETAC ERRTYP,14 ;Negative number 00005194 BRANCH FTLTST ;00005195 ;_ 00005196 MAIN1: SETAC ERRTYP,18 ;Return from level zero 00005197 BRANCH FTLEND ;00005198 ;_ 00005199 NEMO: SETAC ERRTYP,8 ;Variable not present 00005200 BRANCH FTLTST ;00005201 ;_ 00005202 NONAME:SETAC ERRTYP,4 ;Null string 00005203 BRANCH FTLTST ;00005204 ;_ 00005205 NONARY:SETAC ERRTYP,3 ;Erroneous array or table reference 00005206 BRANCH FTLTST ;00005207 ;_ 00005208 OVER: SETAC ERRTYP,21 ;Stack overflow 00005209 BRANCH FTLEND ;00005210 ;_ 00005211 PROTER:SETAC ERRTYP,6 ;Erroneous prototype 00005212 BRANCH FTLTST ;00005213 ;_ 00005214 SCDTER:SETAC ERRTYP,1 ;Illegal data type 00005215 BRANCH SCERST ;00005216 ;_ 00005217 SCLENR:SETAC ERRTYP,14 ;Negative number 00005218 BRANCH SCERST ;00005219 ;_ 00005220 SCLNOR:SETAC ERRTYP,15 ;String overflow 00005221 BRANCH SCERST ;00005222 ;_ 00005223 SCNAME:SETAC ERRTYP,4 ;Null string 00005224 BRANCH SCERST ;00005225 ;_ 00005226 SCNEMO:SETAC ERRTYP,8 ;E3.4.4 BRANCH SCERST ;E3.4.4 ;_ E3.4.4 SIZERR:SETAC ERRTYP,23 ;Object too large 00005227 BRANCH FTLEND ;00005228 ;_ 00005229 UNDF: SETAC ERRTYP,5 ;Undefined function 00005230 BRANCH FTLTST ;00005231 ;_ 00005232 UNDFFE:SETAC ERRTYP,9 ;Function entry point not label 00005233 BRANCH FTLTST ;00005234 ;_ 00005235 UNKNKW:SETAC ERRTYP,7 ;Unknown keyword 00005236 BRANCH FTLTST ;00005237 ;_ 00005238 UNTERR:SETAC ERRTYP,12 ;Illegal I/O unit 00005239 BRANCH FTLTST ;00005240 ;_ 00005241 SCERST:SETAC SCERCL,1 ;Note failure during pattern matching 00005242 BRANCH FTERST ;00005243 ;_ 00005244 FTLTST:SETAC SCERCL,2 ;Note failure outside pattern matchin 00005245 FTERST:ACOMPC ERRLCL,0,,FTLEND,FTLEND ;00005246 ; Check &ERRLIMIT 00005247 DECRA ERRLCL,1 ;Decrement &ERRLIMIT 00005248 ACOMPC TRAPCL,0,,FTERBR,FTERBR ;00005249 ; Check &TRACE 00005250 LOCAPT ATPTR,TKEYL,ERRTKY,FTERBR ;00005251 ; Look for KEYWORD trace 00005252 PUSH SCERCL ;E3.1.3 RCALL ,TRPHND,ATPTR ;E3.3.1 ; Perform trace 00005254 POP SCERCL ;E3.1.3 FTERBR:SELBRA SCERCL, ;00005255 ;_ 00005256 ;---------------------------------------------------------------------* 00005257 .PAGE .SBTTL 'Data' ;00005258 .PSECT SNOBOL4_DATA,SHR,LONG DTLIST:DESCR DTLIST,TTL+MARK,DTLEND-DTLIST-DESCR ;00005259 DESCR 0,0,S ;00005260 DESCR VARSP,0,0 ;STRING 00005261 DESCR 0,0,I ;00005262 DESCR INTGSP,0,0 ;INTEGER 00005263 DESCR 0,0,P ;00005264 DESCR PATSP,0,0 ;PATTERN 00005265 DESCR 0,0,A ;00005266 DESCR ARRSP,0,0 ;ARRAY 00005267 DESCR 0,0,R ;00005268 DESCR RLSP,0,0 ;REAL 00005269 DESCR 0,0,C ;00005270 DESCR CODESP,0,0 ;CODE 00005271 DESCR 0,0,N ;00005272 DESCR NAMESP,0,0 ;NAME 00005273 DESCR 0,0,K ;00005274 DESCR NAMESP,0,0 ;NAME (for keyword) 00005275 DESCR 0,0,E ;00005276 DESCR EXPSP,0,0 ;EXPRESSION 00005277 DESCR 0,0,T ;00005278 DESCR ASSCSP,0,0 ;TABLE 00005279 DTLEND:LHERE , ;00005280 ; 00005281 KNLIST:DESCR KNLIST,TTL+MARK,KNEND-KNLIST-DESCR ;00005282 TRIMCL:DESCR 0,0,I ;&TRIM 00005283 DESCR TRMSP,0,0 ;00005284 TRAPCL:DESCR 0,0,I ;&TRACE 00005285 DESCR TRCESP,0,0 ;00005286 EXLMCL:DESCR 50000,0,I ;&STLIMIT 00005287 DESCR STLMSP,0,0 ;00005288 OUTSW: DESCR 1,0,I ;&OUTPUT 00005289 DESCR OUTSP,0,0 ;00005290 MLENCL:DESCR 5000,0,I ;&MAXLNGTH 00005291 DESCR MAXLSP,0,0 ;00005292 INSW: DESCR 1,0,I ;&INPUT 00005293 DESCR INSP,0,0 ;00005294 FULLCL:DESCR 0,0,I ;&FULLSCAN 00005295 DESCR FULLSP,0,0 ;00005296 TRACL: DESCR 0,0,I ;&FTRACE 00005297 DESCR FTRCSP,0,0 ;00005298 ERRLCL:DESCR 0,0,I ;&ERRLIMIT 00005299 DESCR ERRLSP,0,0 ;00005300 DMPCL: DESCR 0,0,I ;&DUMP 00005301 DESCR DUMPSP,0,0 ;00005302 RETCOD:DESCR 0,0,I ;&CODE 00005303 DESCR CODESP,0,0 ;00005304 ANCCL: DESCR 0,0,I ;&ANCHOR 00005305 DESCR ANCHSP,0,0 ;00005306 ABNDCL:DESCR 0,0,I ;&ABEND 00005307 DESCR ABNDSP,0,0 ;00005308 KNEND: LHERE , ;00005309 ; 00005310 KVLIST:DESCR KVLIST,TTL+MARK,KVEND-KVLIST-DESCR ;00005311 ERRTYP:DESCR 0,0,I ;&ERRTYPE 00005312 ERRTKY:DESCR ERRTSP,0,0 ;00005313 ARBPAT:DESCR ARBPT,0,P ;&ARB 00005314 ARBKY: DESCR ARBSP,0,0 ;00005315 BALPAT:DESCR BALPT,0,P ;&BAL 00005316 BALKY: DESCR BALSP,0,0 ;00005317 FNCPAT:DESCR FNCEPT,0,P ;&FENCE 00005318 FNCEKY:DESCR FNCESP,0,0 ;00005319 ABOPAT:DESCR ABORPT,0,P ;&ABORT 00005320 ABRTKY:DESCR ABORSP,0,0 ;00005321 FALPAT:DESCR FAILPT,0,P ;&FAIL 00005322 FAILKY:DESCR FAILSP,0,0 ;00005323 REMPAT:DESCR REMPT,0,P ;&REM 00005324 REMKY: DESCR REMSP,0,0 ;00005325 SUCPAT:DESCR SUCCPT,0,P ;&SUCCEED 00005326 SUCCKY:DESCR SUCCSP,0,0 ;00005327 FALCL: DESCR 0,0,I ;&STFCOUNT 00005328 FALKY: DESCR STFCSP,0,0 ;00005329 LSTNCL:DESCR 0,0,I ;&LASTNO 00005330 DESCR LSTNSP,0,0 ;00005331 RETPCL:DESCR 0,0,S ;&RTNTYPE 00005332 DESCR RTYPSP,0,0 ;00005333 STNOCL:DESCR 0,0,I ;&STNO 00005334 DESCR STNOSP,0,0 ;00005335 ALPHVL:DESCR 0,0,0 ;&ALPHABET 00005336 DESCR ALNMSP,0,0 ;00005337 EXNOCL:DESCR 0,0,I ;&STCOUNT 00005338 STCTKY:DESCR STCTSP,0,0 ;00005339 LVLCL: DESCR 0,0,I ;&FNCLEVEL 00005340 FNCLKY:DESCR FNCLSP,0,0 ;00005341 KVEND: LHERE , ;00005342 ; 00005343 INLIST:DESCR INLIST,TTL+MARK,2*DESCR ;00005344 DESCR INPUT-DESCR,0,0 ;INPUT block 00005345 DESCR INSP,0,0 ;00005346 OTLIST:DESCR OTLIST,TTL+MARK,4*DESCR ;00005347 DESCR OUTPUT-DESCR,0,0 ;OUTPUT block 00005348 DESCR OUTSP,0,0 ;00005349 DESCR PUNCH-DESCR,0,0 ;PUNCH block 00005350 DESCR PNCHSP,0,0 ;00005351 OTSATL:DESCR OTSATL,TTL+MARK,4*DESCR ;00005352 OUTPUT:DESCR UNITO,0,I ;OUTPUT unit 00005353 DESCR OUTPSP,0,0 ;OUTPUT format 00005354 PUNCH: DESCR UNITP,0,I ;PUNCH unit 00005355 PCHFST:DESCR CRDFSP,0,0 ;PUNCH format 00005356 INSATL:DESCR INSATL,TTL+MARK,2*DESCR ;00005357 INPUT: DESCR UNITI,0,I ;INPUT unit 00005358 DFLSIZ:DESCR 80,0,I ;INPUT length 00005359 ; 00005360 TRLIST:DESCR TRLIST,TTL+MARK,10*DESCR ;00005361 DESCR TVALL,0,0 ;VALUE trace 00005362 VALTRS:DESCR VALSP,0,0 ;00005363 DESCR TLABL,0,0 ;LABEL trace 00005364 DESCR TRLASP,0,0 ;00005365 TFNCLP:DESCR TFENTL,0,0 ;CALL trace 00005366 DESCR TRFRSP,0,0 ;00005367 TFNRLP:DESCR TFEXTL,0,0 ;RETURN trace 00005368 DESCR RETSP,0,0 ;00005369 DESCR TKEYL,0,0 ;KEYWORD trace 00005370 DESCR TRKYSP,0,0 ;00005371 ; 00005372 TRCBLK:DESCR TRCBLK,TTL+MARK,5*DESCR ;V3.7 DESCR 0,FNC,2 ;TRACE FUNCTION DESCRIPTOR V3.7 LIT1CL:DESCR LITFN,FNC,1 ;LITERAL FUNCTION DESCRIPTOR E3.7.1 DESCR 0,0,0 ;VARIABLE TO BE TRACED V3.7 DESCR LITFN,FNC,1 ;LITERAL FUNCTION DESCRIPTOR E3.7.1 DESCR 0,0,0 ;TAG SUPPLIED FOR TRACE V3.7 ; ATRHD: DESCR ATPRCL-DESCR,0,0 ;Array header converting from TABLE 00005373 ATPRCL:DESCR 0,0,0 ;Prototype 00005374 DESCR 2,0,0 ;Dimensionality 00005375 DESCR 1,0,2 ;1:2 second dimension 00005376 ATEXCL:DESCR 1,0,0 ;1:n first dimension 00005377 ; 00005378 ; Data type pairs 00005379 ; 00005380 ATDTP: DESCR A,0,T ;ARRAY-TABLE 00005381 IIDTP: DESCR I,0,I ;INTEGER-INTEGER 00005382 IPDTP: DESCR I,0,P ;INTEGER-PATTERN 00005383 IRDTP: DESCR I,0,R ;INTEGER-REAL 00005384 IVDTP: DESCR I,0,S ;INTEGER-STRING 00005385 PIDTP: DESCR P,0,I ;PATTERN-INTEGER 00005386 PPDTP: DESCR P,0,P ;PATTERN-PATTERN 00005387 PVDTP: DESCR P,0,S ;PATTERN-STRING 00005388 RIDTP: DESCR R,0,I ;REAL-INTEGER 00005389 RPDTP: DESCR R,0,P ;REAL-PATTERN 00005390 RRDTP: DESCR R,0,R ;REAL-REAL 00005391 RVDTP: DESCR R,0,S ;REAL-STRING 00005392 TADTP: DESCR T,0,A ;TABLE-ARRAY 00005393 VCDTP: DESCR S,0,C ;STRING-CODE 00005394 VEDTP: DESCR S,0,E ;STRING-EXPRESSION 00005395 VIDTP: DESCR S,0,I ;STRING-INTEGER 00005396 VPDTP: DESCR S,0,P ;STRING-PATTERN 00005397 VRDTP: DESCR S,0,R ;STRING-REAL 00005398 VVDTP: DESCR S,0,S ;STRING-STRING 00005399 ; 00005400 ARTHCL:DESCR 0,0,0 ;Number of arithmetic operations 00005401 CSTNCL:DESCR 0,0,I ;Compiler statement number 00005402 RSTAT: DESCR 0,0,0 ;Number of reads 00005403 SCNCL: DESCR 0,0,0 ;Number of scanner entrances 00005404 WSTAT: DESCR 0,0,0 ;Number of writes 00005405 TIMECL:DESCR 0,0,0 ;Millisecond time 00005406 ; 00005407 ; SWITCHES 00005408 ; 00005409 ALCL: DESCR 0,0,0 ;Entry point switch for ARG(F,N) 00005410 ARRMRK:DESCR 0,0,0 ;Prototype end switch for ARRAY(P,V) 00005411 CUTNO: DESCR 0,0,0 ;E3.2.2 CNSLCL:DESCR 0,0,0 ;Label redefinition switch 00005412 DATACL:DESCR 0,0,0 ;Prototype end switch for DATA(P) 00005413 FNVLCL:DESCR 0,0,0 ;FUNCTION-VALUE switch for trace 00005414 INICOM:DESCR 0,0,0 ;INITIALIZATION SWITCH E3.10.6 LENFCL:DESCR 0,0,0 ;Length failure switch 00005415 LISTCL:DESCR 1,0,0 ;Compiler listing switch 00005416 LLIST: DESCR 0,0,0 ;Left listing switch 00005417 NAMGCL:DESCR 0,0,0 ;Naming switch for SJSR 00005418 SCERCL:DESCR 0,0,0 ;Error branch switch 00005419 ; 00005420 ; Constants 00005421 ; 00005422 ARBSIZ:DESCR 8*NODESZ,0,0 ;Node size for ARBNO(P) 00005423 CHARCL:DESCR 1,0,0 ;Length constant 1 00005424 CNDSIZ:DESCR CNODSZ,0,B ;Compiler node size 00005425 CODELT:DESCR 200*DESCR,0,C ;Object code excess 00005426 DSCRTW:DESCR 2*DESCR,0,0 ;Constant 2*DESCR 00005427 EOSCL: DESCR EOSTYP,0,0 ;End of statement switch 00005428 ESALIM:DESCR ESASIZ*DESCR,0,0 ;Bound on compilation errors 00005429 EXTVAL:DESCR EXTSIZ*2*DESCR,0,0 ;V3.11 FBLKRQ:DESCR FBLKSZ,0,B ;Quantum on allocated function blocks 00005431 GOBRCL:DESCR 0,0,0 ;Goto break character switch 00005432 GTOCL: DESCR FGOTYP,0,0 ;Goto decision switch 00005433 IOBLSZ:DESCR 2*DESCR,0,B ;Size of I/O blocks 00005434 LNODSZ:DESCR NODESZ+DESCR,0,P ;Size of long pattern node 00005435 NODSIZ:DESCR NODESZ,0,P ;Size of short pattern node 00005436 OBEND: DESCR DESCR*OBOFF+OBLIST,0,0 ;00005437 ; End on bin list 00005438 OCALIM:DESCR OCASIZ*DESCR,0,C ;Size of object code block 00005439 ONECL: DESCR 1,0,0 ;Constant 1 00005440 OUTBLK:DESCR OUTPUT-DESCR,0,0 ;Pointer to OUTPUT block 00005441 SIZLMT:DESCR SIZLIM,0,0 ;Limit on size of data object 00005442 SNODSZ:DESCR NODESZ,0,P ;Small pattern node size 00005443 STARSZ:DESCR 11*DESCR,0,P ;Size of EXPRESSION pattern 00005444 ZEROCL:DESCR 0,0,0 ;Constant zero 00005445 TRSKEL:DESCR TRCBLK,0,0 ;00005446 COMDCT:DESCR 14*DESCR,0,0 ;00005447 COMREG:DESCR ELEMND,0,0 ;Pointer to compiler descriptors 00005448 ; 00005449 ; 00005450 ; 00005451 ; Pointers to Assembled Data Patterns 00005452 ; 00005453 ARBACK:DESCR ARBAK,0,P ;00005454 ARHEAD:DESCR ARHED,0,P ;00005455 ARTAIL:DESCR ARTAL,0,P ;00005456 STRPAT:DESCR STARPT,0,P ;00005457 ; 00005458 ; Function Descriptors 00005459 ; 00005460 ANYCCL:DESCR ANYCFN,FNC,3 ;00005461 ASGNCL:DESCR ASGNFN,FNC,2 ;00005462 ATOPCL:DESCR ATOPFN,FNC,3 ;00005463 BASECL:DESCR BASEFN,FNC,0 ;00005464 BRKCCL:DESCR BRKCFN,FNC,3 ;00005465 CHRCL: DESCR CHRFN,FNC,3 ;00005466 CONCL: DESCR CONFN,FNC,0 ;Argument count is incremented 00005467 DNMECL:DESCR DNMEFN,FNC,2 ;00005468 DNMICL:DESCR DNMIFN,FNC,2 ;00005469 ENDCL: DESCR ENDFN,FNC,0 ;00005471 ENMECL:DESCR ENMEFN,FNC,3 ;00005472 ENMICL:DESCR ENMIFN,FNC,3 ;00005473 ERORCL:DESCR ERORFN,FNC,1 ;00005474 FNCFCL:DESCR FNCFFN,FNC,2 ;00005475 FNMECL:DESCR FNMEFN,FNC,2 ;00005476 GOTGCL:DESCR GOTGFN,FNC,1 ;00005477 GOTLCL:DESCR GOTLFN,FNC,1 ;00005478 GOTOCL:DESCR GOTOFN,FNC,1 ;00005479 INITCL:DESCR INITFN,FNC,1 ;00005480 ITEMCL:DESCR AREFN,FNC,0 ;00005481 LITCL: DESCR LITFN,FNC,0 ;Argument count is incremented 00005482 LNTHCL:DESCR LNTHFN,FNC,3 ;00005483 NMECL: DESCR NMEFN,FNC,2 ;00005484 NNYCCL:DESCR NNYCFN,FNC,3 ;00005485 POSICL:DESCR POSIFN,FNC,3 ;00005486 RPSICL:DESCR RPSIFN,FNC,3 ;00005487 RTBCL: DESCR RTBFN,FNC,3 ;00005488 SCANCL:DESCR SCANFN,FNC,2 ;00005489 SCFLCL:DESCR SCFLFN,FNC,2 ;00005490 SCOKCL:DESCR SCOKFN,FNC,2 ;00005491 SCONCL:DESCR SCONFN,FNC,2 ;00005492 SJSRCL:DESCR SJSRFN,FNC,3 ;00005493 SPNCCL:DESCR SPNCFN,FNC,3 ;00005494 SUCFCL:DESCR SUCFFN,FNC,2 ;00005495 TBCL: DESCR TBFN,FNC,3 ;00005496 INITB: DESCR ABNDB,0,0 ;00005497 INITE: DESCR DTEND+DESCR,0,0 ;00005498 ; 00005499 ; Miscellaneous Data Cells 00005500 ; 00005501 A4PTR: DESCR 0,0,0 ;Scratch descriptor 00005502 A5PTR: DESCR 0,0,0 ;Scratch descriptor 00005503 A6PTR: DESCR 0,0,0 ;Scratch descriptor 00005504 A7PTR: DESCR 0,0,0 ;Scratch descriptor 00005505 BRTYPE:DESCR 0,0,0 ;Break type returned by FORWRD 00005506 CMOFCL:DESCR 0,0,0 ;Compiler offset 00005507 DATSEG:DESCR 0,0,100 ;Beginning of defined data types 00005508 DMPPTR:DESCR 0,0,0 ;Bin pointer for DUMP 00005509 DTCL: DESCR 0,0,0 ;Data type descriptor 00005510 DT1CL: DESCR 0,0,0 ;Data type descriptor 00005511 EMSGCL:DESCR 0,0,0 ;Present error message address 00005512 ERRBAS:DESCR CARDSZ+STNOSZ-SEQSIZ,0,0 ;00005513 ESAICL:DESCR 0,0,0 ;Count of compiler errors 00005514 ETMCL: DESCR 0,0,0 ;Time descriptor 00005515 FCL: DESCR 0,0,0 ;Real number descriptor 00005517 NEXFCL:DESCR FBLKSZ,0,0 ;Offset in function block 00005518 FRTNCL:DESCR 0,0,0 ;Failure return 00005519 GOGOCL:DESCR 0,0,0 ;goto descriptor 00005520 INCL: DESCR 0,0,0 ;Global function descriptor 00005521 IOKEY: DESCR 0,0,0 ;I/O indicator 00005522 MAXLEN:DESCR 0,0,0 ;Maximum length for matching 00005523 MSGNO: DESCR MSGLST,0,0 ;Pointer to error message list 00005524 NAMICL:DESCR 0,0,0 ;Offset on naming list 00005525 NHEDCL:DESCR 0,0,0 ;Name list head offset 00005526 NMOVER:DESCR NAMLSZ*SPDR,0,B ;Name list end offset 00005527 NULVCL:DESCR 0,0,S ;Null string value 00005528 OCICL: DESCR 0,0,0 ;Object code offset 00005529 PATICL:DESCR 0,0,0 ;Pattern code offset 00005530 PDLEND:DESCR PDLBLK+SPDLDR-NODESZ,0,0 ;00005531 ; Pattern history list end 00005532 PDLPTR:DESCR PDLBLK,0,0 ;Pattern history list beginning 00005533 SCL: DESCR 0,0,0 ;Switch descriptor 00005534 STKPTR:DESCR STACK,0,0 ;Pointer to stack 00005535 STYPE: DESCR 0,FNC,0 ;Descriptor return by STREAM 00005536 TBLFNC:DESCR 0,0,0 ;Pointer to last pattern table 00005537 UNIT: DESCR 0,0,0 ;Input unit switch 00005538 VARSYM:DESCR 0,0,0 ;00005539 ; 00005540 ; Program Pointers 00005541 ; 00005542 DATCL: DESCR DEFDAT,FNC,0 ;Defined data objects 00005543 DEFCL: DESCR DEFFNC,FNC,0 ;Defined functions 00005544 FLDCL: DESCR FIELD,0,1 ;Field of defined data objects 00005545 LODCL: DESCR LNKFNC,FNC,0 ;External functions 00005546 PDLHED:DESCR PDLBLK,0,0 ;History list head 00005547 UNDFCL:DESCR UNDF,FNC,0 ;Undefined functions 00005548 ; 00005549 ; Pointers to Specifiers 00005550 ; 00005551 DPSPTR:DESCR DPSP,0,0 ;00005552 XSPPTR:DESCR XSP,0,0 ;00005553 YSPPTR:DESCR YSP,0,0 ;00005554 ZSPPTR:DESCR ZSP,0,0 ;00005555 TSPPTR:DESCR TSP,0,0 ;00005556 ; 00005557 ; Permanent Attribute List Pointers 00005558 ; 00005559 KNATL: DESCR KNLIST,0,0 ;Unprotected keyword list 00005560 KVATL: DESCR KVLIST,0,0 ;Protected keyword list 00005561 TRATL: DESCR TRLIST,0,0 ;Trace list 00005562 ; 00005563 ; Specifiers for Compilation Listing 00005564 ; 00005565 BLNSP: SPEC BLNBUF,0,0,0,STNOSZ ;00005566 ERRSP: SPEC ERRBUF,0,0,0,CARDSZ+STNOSZ-SEQSIZ+1 ;00005567 INBFSP:SPEC INBUF,0,0,STNOSZ,CARDSZ ;00005568 LNBFSP:SPEC INBUF,0,0,0,CARDSZ+DSTSZ+1 ;00005569 NEXTSP:SPEC INBUF,0,0,STNOSZ,CARDSZ-SEQSIZ ;00005570 LNOSP: SPEC INBUF,0,0,0,STNOSZ ;00005571 RNOSP: SPEC INBUF,0,0,CARDSZ+STNOSZ+1,STNOSZ ;00005572 ; 00005573 ; Strings and Specifiers 00005574 ; 00005575 ALPHSP:SPEC ALPHA,0,0,0,ALPHSZ ;Alphabet 00005576 AMPSP: SPEC AMPST,0,0,0,1 ;Ampersand 00005577 CERRSP:SPEC ANYSP,0,0,0,0 ;Buffer specifier 00005578 COLSP: SPEC COLSTR,0,0,0,2 ;Colon for trace messages 00005579 DMPSP: SPEC ANYSP,0,0,0,0 ;Buffer specifier 00005580 DTARSP:SPEC DTARBF,0,0,0,ARRLEN+9 ;00005581 ; Array representation specifier 00005582 PROTSP:SPEC ANYSP,0,0,0,0 ;Buffer specifier 00005583 QTSP: SPEC QTSTR,0,0,0,1 ;Quote for messages 00005584 REALSP:SPEC REALBF,0,0,0,10 ;Specifier for real conversion 00005585 TRACSP:SPEC ANYSP,0,0,0,0 ;Buffer specifier 00005586 ; 00005587 ARRSP: STRING ;00005588 ASSCSP:STRING ;00005589 BLSP: STRING < > ;00005590 BLEQSP:STRING < = > ;00005591 CMASP: STRING <,> ;00005592 EJCTSP:STRING ;00005593 EQLSP: STRING <= > ;00005594 ETIMSP:STRING <,time = > ;00005595 EXDTSP:STRING ;00005596 LEFTSP:STRING ;00005597 LISTSP:STRING ;00005598 LPRNSP:STRING <(> ;00005599 OFSP: STRING < of > ;00005600 RPRNSP:STRING <)> ;00005601 STARSP:STRING <*** > ;00005602 TRCLSP:STRING < call of > ;00005603 TRLVSP:STRING ;00005604 TRSTSP:STRING < Statement > ;00005605 UNLSP: STRING ;00005606 XFERSP:STRING ;00005607 ; 00005608 ; Character Buffers 00005609 ; 00005610 BLNBUF:BUFFER STNOSZ ;Blanks for statment number field 00005611 DTARBF:BUFFER ARRLEN+7 ;Array representation buffer 00005612 ERRBUF:BUFFER CARDSZ+STNOSZ-SEQSIZ+1 ;00005613 INBUF: BUFFER CARDSZ+DSTSZ+1 ;Card input buffer 00005614 REALBF:BUFFER 36 ;Buffer for real number conversion 00005615 ICLBLK:DESCR ICLBLK,TTL+MARK,ICLEND-ICLBLK-DESCR ;00005616 ; 00005617 ; Pointers to Attribute Lists 00005618 ; 00005619 DTATL: DESCR DTLIST,0,0 ;Data type pair list 00005620 FNCPL: DESCR FNLIST,0,0 ;Function pair list 00005621 INATL: DESCR INLIST,0,0 ;Input association pair list 00005622 OUTATL:DESCR OTLIST,0,0 ;Output association pair list 00005623 TVALL: DESCR TVALPL,0,0 ;Value trace pair list 00005624 DESCR VLTRFN,FNC,2 ;Default value trace procedure 00005625 TLABL: DESCR TLABPL,0,0 ;Label trace pair list 00005626 DESCR LABTFN,FNC,1 ;Default label trace procedure 00005627 TFENTL:DESCR TFENPL,0,0 ;Call trace pair list 00005628 DESCR FNTRFN,FNC,2 ;Default call trace procedure 00005629 TFEXTL:DESCR TFEXPL,0,0 ;Return trace pair list 00005630 DESCR FXTRFN,FNC,2 ;Default return trace procedure 00005631 TKEYL: DESCR TKEYPL,0,0 ;Keyword trace pair list 00005632 DESCR KEYTFN,FNC,1 ;Default keyword trace procedure 00005633 ; 00005634 ; Scratch Descriptors 00005635 ; 00005636 A1PTR: DESCR 0,0,0 ;00005637 A2PTR: DESCR 0,0,0 ;00005638 A3PTR: DESCR 0,0,0 ;00005639 ATPTR: DESCR 0,0,0 ;00005640 F1PTR: DESCR 0,0,0 ;00005641 F2PTR: DESCR 0,0,0 ;00005642 IO2PTR:DESCR 0,0,0 ;00005643 IO1PTR:DESCR 0,0,0 ;00005644 LPTR: DESCR 0,0,0 ;Last label pointer 00005645 NVAL: DESCR 0,0,0 ;00005646 IO3PTR:DESCR 0,0,0 ;00005647 IO4PTR:DESCR 0,0,0 ;00005648 TBLCS: DESCR 0,0,0 ;00005649 TMVAL: DESCR 0,0,0 ;00005650 TPTR: DESCR 0,0,0 ;00005651 TCL: DESCR 0,0,0 ;00005652 TSIZ: DESCR 0,0,0 ;00005653 TVAL: DESCR 0,0,0 ;00005654 VVAL: DESCR 0,0,0 ;00005655 WCL: DESCR 0,0,0 ;00005656 WPTR: DESCR 0,0,0 ;00005657 XCL: DESCR 0,0,0 ;00005658 XPTR: DESCR 0,0,0 ;00005659 XSIZ: DESCR 0,0,0 ;00005660 YCL: DESCR 0,0,0 ;00005661 YPTR: DESCR 0,0,0 ;00005662 YSIZ: DESCR 0,0,0 ;00005663 ZCL: DESCR 0,0,0 ;00005664 ZPTR: DESCR 0,0,0 ;00005665 ZSIZ: DESCR 0,0,0 ;00005666 ; 00005667 ; System Descriptors 00005668 ; 00005669 BOSCL: DESCR 0,0,0 ;Offset of beginning of statement 00005670 CMBSCL:DESCR 0,0,0 ;Compiler code base descriptor 00005671 NBSPTR:DESCR 0,0,0 ;Name list base pointer 00005672 FBLOCK:DESCR 0,0,0 ;Function procedure descriptor block 00005673 OCBSCL:DESCR 0,0,0 ;Interpreter code base descriptor 00005674 OCLIM: DESCR 0,0,0 ;End of object code block 00005675 OCSVCL:DESCR 0,0,0 ;Pointer to basic object code 00005676 PATBCL:DESCR 0,0,0 ;Pattern code base descriptor 00005677 SCBSCL:DESCR 0,0,0 ;00005678 SRNCL: DESCR 0,0,0 ;Success return descriptor 00005679 ; 00005680 ; Compiler Descriptors 00005681 ; 00005682 ELEMND:DESCR 0,0,0 ;Element node 00005683 ELEXND:DESCR 0,0,0 ;Temporary node 00005684 ELEYND:DESCR 0,0,0 ;Temporary node 00005685 EXELND:DESCR 0,0,0 ;Temporary node 00005686 EXEXND:DESCR 0,0,0 ;Temporary node 00005687 EXOPCL:DESCR 0,0,0 ;Operator node 00005688 EXOPND:DESCR 0,0,0 ;Operator node 00005689 EXPRND:DESCR 0,0,0 ;Expression node 00005690 FGOND: DESCR 0,0,0 ;Failure goto node 00005691 FORMND:DESCR 0,0,0 ;Object node 00005692 FRNCL: DESCR 0,0,0 ;Failure return descriptor 00005693 GOTOND:DESCR 0,0,0 ;Goto node 00005694 PATND: DESCR 0,0,0 ;Pattern node 00005695 SGOND: DESCR 0,0,0 ;Success goto node 00005696 SUBJND:DESCR 0,0,0 ;Subject node 00005697 ; 00005698 ; Data Pointers 00005699 ; 00005700 DFLFST:DESCR 0,0,0 ;Default output format 00005701 ENDPTR:DESCR 0,0,0 ;'END' 00005702 EXTPTR:DESCR 0,0,0 ;'EXTERNAL' 00005703 FRETCL:DESCR 0,0,0 ;'FRETURN' 00005704 NRETCL:DESCR 0,0,0 ;'NRETURN' 00005705 RETCL: DESCR 0,0,0 ;'RETURN' 00005706 FUNTCL:DESCR 0,0,0 ;'FUNCTION' 00005707 ; 00005708 ; Specifiers 00005709 ; 00005710 DPSP: SPEC 0,0,0,0,0 ;Data type specifier 00005711 HEADSP:SPEC 0,0,0,0,0 ;Matching head specifier 00005712 IOSP: SPEC 0,0,0,0,0 ;I/O specifier 00005713 TAILSP:SPEC 0,0,0,0,0 ;Matching tail specifier 00005714 TEXTSP:SPEC 0,0,0,0,0 ;Compiler statement specifier 00005715 TSP: SPEC 0,0,0,0,0 ;Scratch specifier 00005716 TXSP: SPEC 0,0,0,0,0 ;Scratch specifier 00005717 VSP: SPEC 0,0,0,0,0 ;Scratch specifier 00005718 XSP: SPEC 0,0,0,0,0 ;Scratch specifier 00005719 YSP: SPEC 0,0,0,0,0 ;Scratch specifier 00005720 ZSP: SPEC 0,0,0,0,0 ;Scratch specifier 00005721 ; 00005722 ; Allocator Data 00005723 ; 00005724 ARG1CL:DESCR 0,0,0 ;Scratch descriptor 00005725 BUKPTR:DESCR 0,PTR,S ;Bin pointer 00005726 LSTPTR:DESCR 0,PTR,S ;Pointer to last structure 00005727 AXPTR: DESCR 0,0,0 ;Allocation size descriptor 00005728 SPECR1:SPEC 0,0,0,0,0 ;Scratch specifier 00005729 SPECR2:SPEC 0,0,0,0,0 ;Scratch specifier 00005730 ICLEND:LHERE , ;End of basic block 00005731 ; 00005732 ; Allocator Data 00005733 ; 00005734 BK1CL: DESCR 0,0,0 ;Pointer to block being marked 00005735 BKDX: DESCR 0,0,0 ;Offset in block being marked 00005736 BKDXU: DESCR 0,0,0 ;Offset in block 00005737 BKLTCL:DESCR 0,0,0 ;00005738 BKPTR: DESCR 0,PTR,S ;00005739 BLOCL: DESCR 0,0,0 ;00005740 CONVSW:DESCR 0,0,0 ;CONVAR-GENVAR entry switch 00005741 CPYCL: DESCR 0,0,0 ;Regeneration block pointer 00005742 DESCL: DESCR 0,0,0 ;Regeneration scratch descriptor 00005743 EQUVCL:DESCR 0,0,0 ;Variable identification descriptor 00005744 FRDSCL:DESCR 4*DESCR,0,0 ;00005745 GCBLK: DESCR GCXTTL,0,0 ;Pointer to marking block 00005746 GCNO: DESCR 0,0,0 ;Count of regenerations 00005747 GCMPTR:DESCR 0,0,0 ;Pointer to basic blocks 00005748 GCREQ: DESCR 0,0,0 ;Space required from regeneration 00005749 GCGOT: DESCR 0,0,I ;Space obtained from regeneration 00005750 LCPTR: DESCR 0,0,0 ;Scratch descriptor 00005751 MVSGPT:DESCR 0,0,0 ;Compression boundary pointer 00005752 NODPCL:DESCR 0,0,0 ;Regeneration switch 00005753 OBPTR: DESCR OBLIST,PTR,S ;Pointer to bins 00005754 OFSET: DESCR 0,0,0 ;Offset in block during regeneration 00005755 PRMDX: DESCR PRMSIZ,0,0 ;Size of basic block list 00005756 PRMPTR:DESCR PRMTBL,0,0 ;Pointer to list of basic blocks 00005757 ST1PTR:DESCR 0,PTR,S ;Regeneration link pointer 00005758 ST2PTR:DESCR 0,PTR,S ;Regeneration link pointer 00005759 TEMPCL:DESCR 0,PTR,0 ;Scracth descriptor 00005760 TOPCL: DESCR 0,0,0 ;Pointer to block title 00005761 TTLCL: DESCR 0,0,0 ;Pointer to block title 00005762 TWOCL: DESCR 2*DESCR,0,B ;Size of string to be marked 00005763 ; 00005764 ; 00005765 FRSGPT:DESCR 0,PTR,0 ;Position pointer 00005766 HDSGPT:DESCR 0,PTR,0 ;Head of allocated data region 00005767 TLSGP1:DESCR 0,PTR,0 ;End of allocated data region 00005768 GCXTTL:DESCR GCXTTL,TTL+MARK,DESCR ;00005769 ; Block to prime marking procedure 00005770 DESCR 0,0,0 ;Pointer to block to mark 00005771 ; 00005772 ; Machine-dependent Data 00005773 ; 00005774 COPY MDATA ;Segment of machine-dependent data 00005775 ; 00005776 ; Function Table 00005777 ; 00005778 FTABLE:DESCR FTABLE,TTL+MARK,FTBLND-FTABLE-DESCR ;00005779 ; 00005780 ; Primitive Functions 00005781 ; 00005782 ANYFN: DESCR ANY,0,1 ;00005783 DESCR 0,0,0 ;00005784 APLYFN:DESCR APPLY,FNC,1 ;00005785 DESCR 0,0,0 ;00005786 ARBOFN:DESCR ARBNO,0,1 ;00005787 DESCR 0,0,0 ;00005788 ARGFN: DESCR ARG,0,2 ;00005789 DESCR 0,0,0 ;00005790 ARRAFN:DESCR ARRAY,0,2 ;00005791 DESCR 0,0,0 ;00005792 ASSCFN:DESCR ASSOC,0,2 ;00005793 DESCR 0,0,0 ;00005794 BACKFN:DESCR BKSPCE,0,1 ;00005795 DESCR 0,0,0 ;00005796 BREAFN:DESCR BREAK,0,1 ;00005797 DESCR 0,0,0 ;00005798 CLEAFN:DESCR CLEAR,0,1 ;00005799 DESCR 0,0,0 ;00005800 CODEFN:DESCR CODER,0,1 ;00005801 DESCR 0,0,0 ;00005802 COLEFN:DESCR COLECT,0,1 ;00005803 DESCR 0,0,0 ;00005804 CNVRFN:DESCR CNVRT,0,2 ;00005805 DESCR 0,0,0 ;00005806 COPYFN:DESCR COPY,0,1 ;00005807 DESCR 0,0,0 ;00005808 DATFN: DESCR DATE,0,1 ;00005809 DESCR 0,0,0 ;00005810 DATDFN:DESCR DATDEF,0,1 ;00005811 DESCR 0,0,0 ;00005812 DEFIFN:DESCR DEFINE,0,2 ;00005813 DESCR 0,0,0 ;00005814 DIFFFN:DESCR DIFFER,0,2 ;00005815 DESCR 0,0,0 ;00005816 DTCHFN:DESCR DETACH,0,1 ;00005817 DESCR 0,0,0 ;00005818 DTFN: DESCR DT,0,1 ;00005819 DESCR 0,0,0 ;00005820 DUMPFN:DESCR DMP,0,1 ;00005821 DESCR 0,0,0 ;00005822 DUPLFN:DESCR DUPL,0,2 ;00005823 DESCR 0,0,0 ;00005824 ENDFFN:DESCR ENFILE,0,1 ;00005825 DESCR 0,0,0 ;00005826 EQFN: DESCR EQ,0,2 ;00005827 DESCR 0,0,0 ;00005828 EVALFN:DESCR EVAL,0,1 ;00005829 DESCR 0,0,0 ;00005830 FLDSFN:DESCR FIELDS,0,2 ;00005831 DESCR 0,0,0 ;00005832 GEFN: DESCR GE,0,2 ;00005833 DESCR 0,0,0 ;00005834 GTFN: DESCR GT,0,2 ;00005835 DESCR 0,0,0 ;00005836 IDENFN:DESCR IDENT,0,2 ;00005837 DESCR 0,0,0 ;00005838 INTGFN:DESCR INTGER,0,1 ;00005839 DESCR 0,0,0 ;00005840 ITEMFN:DESCR ITEM,FNC,1 ;00005841 DESCR 0,0,0 ;00005842 LEFN: DESCR LE,0,2 ;00005843 DESCR 0,0,0 ;00005844 LENFN: DESCR LEN,0,1 ;00005845 DESCR 0,0,0 ;00005846 LGTFN: DESCR LGT,0,2 ;00005847 DESCR 0,0,0 ;00005848 LOADFN:DESCR LOAD,0,2 ;00005849 DESCR 0,0,0 ;00005850 LOCFN: DESCR LOCAL,0,2 ;00005851 DESCR 0,0,0 ;00005852 LTFN: DESCR LT,0,2 ;00005853 DESCR 0,0,0 ;00005854 NEFN: DESCR NE,0,2 ;00005855 DESCR 0,0,0 ;00005856 NOTAFN:DESCR NOTANY,0,1 ;00005857 DESCR 0,0,0 ;00005858 OPSYFN:DESCR OPSYN,0,3 ;00005859 DESCR 0,0,0 ;00005860 POSFN: DESCR POS,0,1 ;00005861 DESCR 0,0,0 ;00005862 PRINFN:DESCR PRINT,0,3 ;00005863 DESCR 0,0,0 ;00005864 PROTFN:DESCR PROTO,0,1 ;00005865 DESCR 0,0,0 ;00005866 REMDFN:DESCR REMDR,0,2 ;00005867 DESCR 0,0,0 ;00005868 RPLAFN:DESCR RPLACE,0,3 ;00005869 DESCR 0,0,0 ;00005870 READFN:DESCR READ,0,3 ;00005871 DESCR 0,0,0 ;00005872 REWNFN:DESCR REWIND,0,1 ;00005873 DESCR 0,0,0 ;00005874 RPOSFN:DESCR RPOS,0,1 ;00005875 DESCR 0,0,0 ;00005876 RTABFN:DESCR RTAB,0,1 ;00005877 DESCR 0,0,0 ;00005878 SIZEFN:DESCR SIZE,0,1 ;00005879 DESCR 0,0,0 ;00005880 SPANFN:DESCR SPAN,0,1 ;00005881 DESCR 0,0,0 ;00005882 STPTFN:DESCR STOPTR,0,2 ;00005883 DESCR 0,0,0 ;00005884 TABFN: DESCR TAB,0,1 ;00005885 DESCR 0,0,0 ;00005886 TIMFN: DESCR TIME,0,1 ;00005887 DESCR 0,0,0 ;00005888 TRCEFN:DESCR TRACE,0,4 ;00005889 DESCR 0,0,0 ;00005890 TRIMFN:DESCR TRIM,0,1 ;00005891 DESCR 0,0,0 ;00005892 UNLDFN:DESCR UNLOAD,0,1 ;00005893 DESCR 0,0,0 ;00005894 VALFN: DESCR FIELD,0,1 ;00005895 DESCR VALBLK,0,0 ;00005896 FTBLND:LHERE , ;00005897 ; 00005898 INITLS:DESCR INITLS,TTL+MARK,8*DESCR ;00005899 DESCR DTLIST,0,0 ;00005900 DESCR FNLIST,0,0 ;00005901 DESCR INLIST,0,0 ;00005902 DESCR KNLIST,0,0 ;00005903 DESCR KVLIST,0,0 ;00005904 DESCR OTLIST,0,0 ;00005905 DESCR OTSATL,0,0 ;00005906 DESCR TRLIST,0,0 ;00005907 ; 00005908 ; Function Pair List 00005909 ; 00005910 FNLIST:DESCR FNLIST,TTL+MARK,FNCPLE-FNLIST-DESCR ;00005911 DESCR ANYFN,FNC,0 ;ANY(CS) 00005912 DESCR ANYSP,0,0 ;00005913 DESCR APLYFN,FNC,0 ;APPLY(F,A1,...,AN) 00005914 DESCR APLYSP,0,0 ;00005915 DESCR ARBOFN,FNC,0 ;ARBNO(P) 00005916 DESCR ARBNSP,0,0 ;00005917 DESCR ARGFN,FNC,0 ;ARG(F,N) 00005918 DESCR ARGSP,0,0 ;00005919 DESCR ARRAFN,FNC,0 ;ARRAY(P,V) 00005920 DESCR ARRSP,0,0 ;00005921 DESCR BACKFN,FNC,0 ;BACKSPACE(N) 00005922 DESCR BACKSP,0,0 ;00005923 DESCR BREAFN,FNC,0 ;BREAK(CS) 00005924 DESCR BRKSP,0,0 ;00005925 DESCR CLEAFN,FNC,0 ;CLEAR() 00005926 DESCR CLERSP,0,0 ;00005927 DESCR CODEFN,FNC,0 ;CODE(S) 00005928 DESCR CODESP,0,0 ;00005929 DESCR COLEFN,FNC,0 ;COLLECT(N) 00005930 DESCR CLSP,0,0 ;00005931 DESCR CNVRFN,FNC,0 ;CONVERT(V,DT) 00005932 DESCR CNVTSP,0,0 ;00005933 DESCR COPYFN,FNC,0 ;COPY(V) 00005934 DESCR COPYSP,0,0 ;00005935 DESCR DATDFN,FNC,0 ;DATA(P) 00005936 DESCR DATASP,0,0 ;00005937 DESCR DATFN,FNC,0 ;E3.0.5 DESCR DATSP,0,0 ;00005939 DESCR DEFIFN,FNC,0 ;DEFINE(P,L) 00005940 DESCR DEFISP,0,0 ;00005941 DESCR DIFFFN,FNC,0 ;DIFFER(V1,V2) 00005942 DESCR DIFFSP,0,0 ;00005943 DESCR DTCHFN,FNC,0 ;DETACH(V) 00005944 DESCR DTCHSP,0,0 ;00005945 DESCR DTFN,FNC,0 ;DATATYPE(V) 00005946 DESCR DTSP,0,0 ;00005947 DESCR DUMPFN,FNC,0 ;DUMP() 00005948 DESCR DUMPSP,0,0 ;00005949 DESCR DUPLFN,FNC,0 ;DUPL(S,N) 00005950 DESCR DUPLSP,0,0 ;00005951 DESCR ENDFFN,FNC,0 ;ENDFILE(N) 00005952 DESCR ENDFSP,0,0 ;00005953 DESCR EQFN,FNC,0 ;EQ(I1,I2) 00005954 DESCR EQSP,0,0 ;00005955 DESCR EVALFN,FNC,0 ;EVAL(E) 00005956 DESCR EVALSP,0,0 ;00005957 DESCR FLDSFN,FNC,0 ;FIELD(V,N) 00005958 DESCR FLDSSP,0,0 ;00005959 DESCR GEFN,FNC,0 ;GE(I1,I2) 00005960 DESCR GESP,0,0 ;00005961 DESCR GTFN,FNC,0 ;GT(I1,I2) 00005962 DESCR GTSP,0,0 ;00005963 DESCR IDENFN,FNC,0 ;IDENT(V1,V2) 00005964 DESCR IDENSP,0,0 ;00005965 DESCR READFN,FNC,0 ;INPUT(V,N,L) 00005966 DESCR INSP,0,0 ;00005967 DESCR INTGFN,FNC,0 ;INTEGER(V) 00005968 DESCR INTGSP,0,0 ;00005969 DESCR ITEMFN,FNC,0 ;ITEM(A,I1,...,IN) 00005970 DESCR ITEMSP,0,0 ;00005971 DESCR LENFN,FNC,0 ;LEN(N) 00005972 DESCR LENSP,0,0 ;00005973 DESCR LEFN,FNC,0 ;LE(I1,I2) 00005974 DESCR LESP,0,0 ;00005975 DESCR LGTFN,FNC,0 ;LGT(S1,S2) 00005976 DESCR LGTSP,0,0 ;00005977 DESCR LOADFN,FNC,0 ;LOAD(P) 00005978 DESCR LOADSP,0,0 ;00005979 DESCR LOCFN,FNC,0 ;LOCAL(F,N) 00005980 DESCR LOCSP,0,0 ;00005981 DESCR LTFN,FNC,0 ;LT(I1,I2) 00005982 DESCR LTSP,0,0 ;00005983 DESCR NEFN,FNC,0 ;NE(I1,I2) 00005984 DESCR NESP,0,0 ;00005985 DESCR NOTAFN,FNC,0 ;NOTANY(CS) 00005986 DESCR NNYSP,0,0 ;00005987 DESCR OPSYFN,FNC,0 ;OPSYN(F1,F2,N) 00005988 DESCR OPSNSP,0,0 ;00005989 DESCR PRINFN,FNC,0 ;OUTPUT(V,N,F) 00005990 DESCR OUTSP,0,0 ;00005991 DESCR POSFN,FNC,0 ;POS(N) 00005992 DESCR POSSP,0,0 ;00005993 DESCR PROTFN,FNC,0 ;PROTOTYPE(A) 00005994 DESCR PRTSP,0,0 ;00005995 DESCR REMDFN,FNC,0 ;REMDR(N,M) 00005996 DESCR REMDSP,0,0 ;00005997 DESCR REWNFN,FNC,0 ;REWIND(N) 00005998 DESCR REWNSP,0,0 ;00005999 DESCR RPLAFN,FNC,0 ;REPLACE(S,CS1,CS2) 00006000 DESCR RPLCSP,0,0 ;00006001 DESCR RPOSFN,FNC,0 ;RPOS(N) 00006002 DESCR RPOSSP,0,0 ;00006003 DESCR RTABFN,FNC,0 ;RTAB(N) 00006004 DESCR RTABSP,0,0 ;00006005 DESCR SIZEFN,FNC,0 ;SIZE(S) 00006006 DESCR SIZESP,0,0 ;00006007 DESCR SPANFN,FNC,0 ;SPAN(CS) 00006008 DESCR SPANSP,0,0 ;00006009 DESCR STPTFN,FNC,0 ;STOPTR(V,R) 00006010 DESCR STPTSP,0,0 ;00006011 DESCR TABFN,FNC,0 ;TAB(N) 00006012 DESCR TABSP,0,0 ;00006013 DESCR ASSCFN,FNC,0 ;TABLE(N,M) 00006014 DESCR ASSCSP,0,0 ;00006015 DESCR TIMFN,FNC,0 ;TIME() 00006016 DESCR TIMSP,0,0 ;00006017 DESCR TRCEFN,FNC,0 ;TRACE(V,R,T,F) 00006018 DESCR TRCESP,0,0 ;00006019 DESCR TRIMFN,FNC,0 ;TRIM(S) 00006020 DESCR TRMSP,0,0 ;00006021 DESCR UNLDFN,FNC,0 ;UNLOAD(S) 00006022 DESCR UNLDSP,0,0 ;00006023 DESCR VALFN,FNC,0 ;VALUE(S) 00006024 DESCR VALSP,0,0 ;00006025 ARRAY 10*2 ;Space for 10 more functions 00006026 FNCPLE:LHERE , ;End of function pair list 00006027 OPTBL: DESCR OPTBL,TTL+MARK,OPTBND-OPTBL-DESCR ;00006028 ADDFN: DESCR ADD,0,2 ;X + Y addition 00006029 DESCR 0,0,0 ;00006030 DESCR 30,0,29 ;00006031 BIAMFN:DESCR UNDF,FNC,0 ;X & Y definable 00006032 DESCR 0,0,0 ;00006033 DESCR 5,0,4 ;00006034 BIATFN:DESCR UNDF,FNC,0 ;X @ Y definable 00006035 DESCR 0,0,0 ;00006036 DESCR 25,0,24 ;00006037 BINGFN:DESCR UNDF,FNC,0 ;X \ Y definable 00006038 DESCR 0,0,0 ;00006039 DESCR 70,0,70 ;00006040 BIPDFN:DESCR UNDF,FNC,0 ;X # Y definable 00006041 DESCR 0,0,0 ;00006042 DESCR 35,0,34 ;00006043 BIPRFN:DESCR UNDF,FNC,0 ;X % Y definable 00006044 DESCR 0,0,0 ;00006045 DESCR 45,0,44 ;00006046 BIQSFN:DESCR UNDF,FNC,0 ;X ? Y definable 00006047 DESCR 0,0,0 ;00006048 DESCR 70,0,69 ;00006049 CONFN: DESCR CON,0,2 ;X Y concatenation 00006050 DESCR 0,0,0 ;00006051 DESCR 20,0,19 ;00006052 DIVFN: DESCR DIV,0,2 ;X / Y division 00006053 DESCR 0,0,0 ;00006054 DESCR 40,0,39 ;00006055 DOLFN: DESCR DOL,0,2 ;X $ Y immediate naming 00006056 DESCR 0,0,0 ;00006057 DESCR 60,0,59 ;00006058 EXPFN: DESCR EXP,0,2 ;X ** Y exponentiation 00006059 DESCR 0,0,0 ;00006060 DESCR 50,0,50 ;00006061 MPYFN: DESCR MPY,0,2 ;X * Y multiplication 00006062 DESCR 0,0,0 ;00006063 DESCR 42,0,41 ;00006064 NAMFN: DESCR NAM,0,2 ;X . Y naming 00006065 DESCR 0,0,0 ;00006066 DESCR 60,0,59 ;00006067 ORFN: DESCR OR,0,2 ;X | Y alternation 00006068 DESCR 0,0,0 ;00006069 DESCR 10,0,9 ;00006070 SUBFN: DESCR SUB,0,2 ;X - Y subtraction 00006071 DESCR 0,0,0 ;00006072 DESCR 30,0,29 ;00006073 AROWFN:DESCR UNDF,FNC,0 ;!X definable 00006074 DESCR 0,0,0 ;00006075 ATFN: DESCR ATOP,0,1 ;@X scanner position 00006076 DESCR 0,0,0 ;00006077 BARFN: DESCR UNDF,FNC,0 ;|X definable 00006078 DESCR 0,0,0 ;00006079 DOTFN: DESCR NAME,0,1 ;.X name 00006080 DESCR 0,0,0 ;00006081 INDFN: DESCR IND,0,1 ;$X indirect reference 00006082 DESCR 0,0,0 ;00006083 KEYFN: DESCR KEYWRD,0,1 ;&X keyword 00006084 DESCR 0,0,0 ;00006085 MNSFN: DESCR MNS,0,1 ;-X minus 00006086 DESCR 0,0,0 ;00006087 NEGFN: DESCR NEG,0,1 ;\X negation 00006088 DESCR 0,0,0 ;00006089 PDFN: DESCR UNDF,FNC,0 ;#X definable 00006090 DESCR 0,0,0 ;00006091 PLSFN: DESCR PLS,0,1 ;+X plus 00006092 DESCR 0,0,0 ;00006093 PRFN: DESCR UNDF,FNC,0 ;%X definable 00006094 DESCR 0,0,0 ;00006095 QUESFN:DESCR QUES,0,1 ;?X interrogation 00006096 DESCR 0,0,0 ;00006097 SLHFN: DESCR UNDF,FNC,0 ;/X definable 00006098 DESCR 0,0,0 ;00006099 STRFN: DESCR STR,0,1 ;*X unevaluated expression 00006100 DESCR 0,0,0 ;00006101 OPTBND:LHERE , ;End of operator table 00006102 ; 00006103 ; 00006104 AREFN: DESCR ITEM,FNC,1 ;Array or table reference 00006105 ASGNFN:DESCR ASGN,0,2 ;X = Y 00006106 BASEFN:DESCR BASE,0,0 ;Base object code 00006107 ENDAFN:DESCR ARGNER,0,0 ;Safety exit on trace psuedo-code 00006108 ENDFN: DESCR END,0,0 ;End of program 00006109 ERORFN:DESCR EROR,0,1 ;Erroneous statement 00006110 FNTRFN:DESCR FENTR,0,2 ;Call tracing 00006111 FXTRFN:DESCR FNEXTR,0,2 ;Return tracing 00006112 GOTGFN:DESCR GOTG,0,1 ;: 00006113 GOTLFN:DESCR GOTL,0,1 ;:(L) 00006114 GOTOFN:DESCR GOTO,0,1 ;Internal goto 00006115 INITFN:DESCR INIT,0,1 ;Statement initialization 00006116 KEYTFN:DESCR KEYTR,0,2 ;Keyword tracing 00006117 LABTFN:DESCR LABTR,0,2 ;Label tracing 00006118 LITFN: DESCR LIT,0,1 ;Literal evaluation 00006119 SCANFN:DESCR SCAN,0,2 ;Pattern matching 00006120 SJSRFN:DESCR SJSR,0,3 ;Pattern matching with replacement 00006121 VLTRFN:DESCR VALTR,0,2 ;Value tracing 00006122 ANYCFN:DESCR ANYC,0,3 ;Matching for ANY(S) 00006123 ARBFFN:DESCR ARBF,0,2 ;Failure for ARB 00006124 ARBNFN:DESCR ARBN,0,2 ;Matching for ARBNO(P) 00006125 ATOPFN:DESCR ATP,0,3 ;Matching for @X 00006126 CHRFN: DESCR CHR,0,3 ;Matching for string 00006127 BALFN: DESCR BAL,0,2 ;Matching for BAL 00006128 BALFFN:DESCR BALF,0,2 ;Failure for BAL 00006129 BRKCFN:DESCR BRKC,0,3 ;Matching for BREAK(S) 00006130 DNMEFN:DESCR DNME,0,2 ;00006131 DNMIFN:DESCR DNME1,0,2 ;00006132 EARBFN:DESCR EARB,0,2 ;00006133 DSARFN:DESCR DSAR,0,3 ;00006134 ENMEFN:DESCR ENME,0,3 ;00006135 ENMIFN:DESCR ENMI,0,3 ;00006136 FARBFN:DESCR FARB,0,2 ;00006137 FNMEFN:DESCR FNME,0,2 ;00006138 LNTHFN:DESCR LNTH,0,3 ;Matching for LEN(N) 00006139 NMEFN: DESCR NME,0,2 ;00006140 NNYCFN:DESCR NNYC,0,3 ;Matching for NOTANY(S) 00006141 ONARFN:DESCR ONAR,0,2 ;00006142 ONRFFN:DESCR ONRF,0,2 ;00006143 POSIFN:DESCR POSI,0,3 ;Matching for POS(N) 00006144 RPSIFN:DESCR RPSI,0,3 ;Matching for RPOS(N) 00006145 RTBFN: DESCR RTB,0,3 ;Matching for RTAB(N) 00006146 SALFFN:DESCR SALF,0,2 ;00006147 SCFLFN:DESCR FAIL,0,2 ;00006148 SCOKFN:DESCR SCOK,0,2 ;Successful match procedure 00006149 SCONFN:DESCR SCON,0,2 ;00006150 SPNCFN:DESCR SPNC,0,3 ;Matching for SPAN(S) 00006151 STARFN:DESCR STAR,0,3 ;Matching for *X 00006152 TBFN: DESCR TB,0,3 ;Matching for TAB(N) 00006153 ABORFN:DESCR RTNUL3,0,3 ;Matching for ABORT 00006154 FNCEFN:DESCR FNCE,0,2 ;Matching for FENCE 00006155 FNCFFN:DESCR RTNUL3,0,2 ;Failure for FENCE 00006156 SUCFFN:DESCR SUCF,0,2 ;Matching for SUCCEED 00006157 ; 00006158 ; Initialization Data for Functions 00006159 ; 00006160 abndsp:string ;00006161 aborsp:string ;00006162 alnmsp:string ;00006163 anchsp:string ;00006164 anysp: string ;00006165 aplysp:string ;00006166 arbsp: string ;00006167 arbnsp:string ;00006168 argsp: string ;00006169 backsp:string ;00006170 balsp: string ;00006171 brksp: string ;00006172 trfrsp:string ;00006173 clersp:string ;00006174 codesp:string ;00006175 clsp: string ;00006176 cnvtsp:string ;00006177 copysp:string ;00006178 datsp: string ;00006179 datasp:string ;00006180 defisp:string ;00006181 diffsp:string ;00006182 dtchsp:string ;00006183 dtsp: string ;00006184 dumpsp:string ;00006185 duplsp:string ;00006186 endsp: string ;00006187 endfsp:string ;00006188 eqsp: string ;00006189 errlsp:string ;00006190 errtsp:string ;00006191 evalsp:string ;00006192 expsp: string ;00006193 failsp:string ;00006194 fncesp:string ;00006195 fldssp:string ;00006196 fnclsp:string ;00006197 fretsp:string ;00006198 ftrcsp:string ;00006199 fullsp:string ;00006200 funtsp:string ;00006201 gesp: string ;00006202 gtsp: string ;00006203 idensp:string ;00006204 insp: string ;00006205 intgsp:string ;00006206 itemsp:string ;00006207 trkysp:string ;00006208 trlasp:string