COMMENT  VALID 00064 PAGES VERSION 17-1(238) C REC PAGE DESCRIPTION C00001 00001 C00006 00002 HISTORY C00029 00003 LSTON (GEN) C00038 00004 TABLEDATA (EXEC ROUTINES -- GLOBAL VARIABLES) C00044 00005 TABCONDATA (EXEC ROUTINES -- GLOBAL VARIABLES) C00047 00006 DSCR GENINI C00051 00007 DSCR GETOP, GETADL, GETAD C00053 00008 DSCR -- SAIL DECLARATION EXECS C00058 00009 DSCR TYPSET, VALSET, XOWSET, etc. C00061 00010 DSCR TCON, BTRU, BFAL, BNUL, BINF C00064 00011 DSCR TWID10, ECHK, ESET C00067 00012 DSCR DWN, BLOCK, BLNAME, ENTID, UP, NAMCHK, etc. C00077 00013 ^ENTID: C00083 00014 C00091 00015 Check for match on block names. C00093 00016 DSCR RQ00, RQSET, SRCSWT C00099 00017 C00101 00018 C00106 00019 C00109 00020 ^SRCSWT: C00112 00021 DSCR DFPREP, DCPREP, DWPREP, DFPINS, DFSET, DFENT, MACOFF, MACON C00126 00022 DSCR STCAT C00138 00023 DSCR DCLNT1,DCLNT2 C00146 00024 DSCR CNDRCY, CNDRCN, CNDRCP C00154 00025 DSCR LETSET, LETENT C00157 00026 DSCR TWCOND,SWICHP,SWPOFF,PSWICH,OKEOF C00165 00027 ^SETWHL: EXCH SP,STPSAV GET STRING POINTER C00178 00028 SUBTTL EXECS for Entry Declaration C00180 00029 DSCR ALOT C00185 00030 ^ALOT: ROUTINE TO HANDLE ALLOCATION C00189 00031 C00193 00032 BAIL < C00205 00033 C00212 00034 Comment C00218 00035 NOSY: PUSHJ P,URGSTR IF ON STRING RING.... C00228 00036 #UQ# JFR 8-1-75 THIS GETS MODIFIED!!!!!!!!!! C00231 00037 DSCR PDOUT C00237 00038 DOLVIN: PUSH P,PNT2 C00242 00039 ROUTINE TO PUT OUT LOCAL VAR INFO -- USED BY DIS C00248 00040 %AA% -- SDFLTS C00249 00041 Allo -- Allocate One Type of Symbol C00256 00042 ROUTINE TO ALLOCATE SPACE FOR TEMP CELLS AND TO OUTPUT C00264 00043 REQINI -- USER REQUIRED INITIALIZTIONS C00269 00044 DSCR DONES C00273 00045 C00282 00046 REN < C00284 00047 C00289 00048 C00297 00049 MEMORY and LOCATION EXECS, ALSO UINCLL C00301 00050 MINOR RECORD EXECS C00308 00051 RCFPIK -- ROUTINE TO DECODE RECORD INDEX C00310 00052 RCFREF -- EXEC ROUTINE FOR HANDLING RECORD FIELD REFERENCES C00318 00053 RECORD TYPE JUSTIFICATION ROUTINE C00320 00054 ROUTINE TO HANDLE REFERENCE COUNT ADJUSTMENT C00324 00055 DSCR MAKBUK, FREBUK C00326 00056 BEGIN ERRORS C00332 00057 DSCR SCNBAK,POPBAK,KILPOP,QREM2,QTYPCK C00337 00058 DSCR UNDEC -- Undeclared identifiers C00343 00059 DSCR QDEC0,1,2 QARSUB QARDEC QPARM QPRDEC C00350 00060 BEGIN SCOMM C00351 00061 BEGIN INLINE C00353 00062 DSCR CODNIT, WRDNIT, ONEWRD, SETSIX, SETOP, CODIND, CODREG, etc. C00361 00063 ^CESSGO:MOVE TEMP,OPDUN SAVING OPDUN C00367 00064 BEGIN COUNT C00370 ENDMK C; COMMENT HISTORY AUTHOR,REASON 021 102100000356 ; COMMENT  VERSION 17-1(238) 6-2-75 BY RLS BUG ##U#K# STRING PROCEDURE IS NOT A STRING VERSION 17-1(237) 5-31-75 BY JFR TENEX BAIL FILE NAME FORMAT, P.46 VERSION 17-1(236) 4-5-75 BY JFR DEFAULTABLE PARAM CODES IN PR.DESCR/38, STRINGS IN RECORDS/52 VERSION 17-1(235) 3-10-75 BY RHT MAKE TOPLEVPNTVARS GO ON RBLIST VERSION 17-1(234) 3-4-75 BY RHT %CB% ADD CHANGES FOR NEW-STYLE RECORDS (E.G., $CLASS) VERSION 17-1(233) 2-23-75 BY JFR BAIL P. 32 LAST WORD OF CODE FOR BLOCKS VERSION 17-1(232) 2-16-75 BY JFR BAIL P.48 FOR KNOWLEDGE OF SAIL RUNTIMES VERSION 17-1(231) 2-16-75 BY JFR BAIL P.32,33 CORRECT BITS FOR RECURSIVE PROCS, INSTALL RECS+REFS VERSION 17-1(230) 2-16-75 BY JFR POKE VERSION 17-1(229) 2-1-75 BY JFR INSTALL RCDFLG, NEQ ZERO DURING RECORD CLASS DECL VERSION 17-1(228) 2-1-75 BY JFR BAIL--FORCE BLOCK NAMES UPPER, FLAG SIMPLE PROCS, ALLOW USER BAIL.REL [P 32,48] VERSION 17-1(227) 2-1-75 BY RLS MAKE EXPR!TYPE RECURSIVE VERSION 17-1(226) 1-24-75 BY JFR BAIL BUG--CREATED BLOCK NAMES, P.32 VERSION 17-1(225) 12-13-74 BY JFR BAIL EXTERNAL LINKAGE VERSION 17-1(224) 12-10-74 BY JFR BAIL--FORCE COORDINATES OUT AT BEGINs VERSION 17-1(223) 12-10-74 BY JFR FIX INFO ON PROCEDURES FOR .SM1 FILE VERSION 17-1(222) 12-10-74 BY JFR TRY TO FIX BAIL INTERNAL/EXTERNAL LINKAGE VERSION 17-1(221) 12-7-74 BY JFR ATTEMPT TO FIX BAIL INTERNAL/EXTRNAL LINKAGE. POSTPONED VERSION 17-1(220) 12-7-74 BY JFR MAKE REQUIRE "SYS:BAIL.REL" LOAD!MODULE AUTOMATIC UNDER BAIL SWITCH VERSION 17-1(219) 11-13-74 BY JFR BAIL BUG P. 32 VERSION 17-1(218) 11-13-74 BY JFR BAIL FIX P.45 VERSION 17-1(217) 11-8-74 BY JFR FIX BAIL DEFAULT BLOCK NAME CREATION AND COUNTING VERSION 17-1(216) 11-7-74 BY JFR BAIL--CREATED BLOCK NAMES PUT OUT AT BAISYM RATHER THAN AT BEGIN VERSION 17-1(215) 11-3-74 BY RHT BUG #TR# REQUIRE SPACE CODE VERSION 17-1(214) 10-13-74 BY JFR JUST CHECKING VERSION 17-1(213) 10-13-74 BY JFR BAIL--DON'T INVENT BLOCK NAMES IF NOT A BAIL COMPILATION VERSION 17-1(212) 10-10-74 BY RHT FEAT %BR% REMOVE HACKS VERSION 17-1(211) 9-29-74 BY JFR BAIL BUG P.12 VERSION 17-1(210) 9-26-74 BY JFR INSERT MISSING ZERODATA AROUND %%VARB (P.59) VERSION 17-1(209) 9-26-74 BY JFR BAIL--CHANGES TO WHICH SYMBOLS GO TO .SM1 FILE VERSION 17-1(208) 9-24-74 BY JFR FIX BAIL .SM1 DEC-10 IO VERSION 17-1(207) 9-20-74 BY JFR QUALITY CONTROL VERSION 17-1(206) 9-20-74 BY JFR INSTALL BAIL VERSION 17-1(205) 9-20-74 VERSION 17-1(204) 9-20-74 VERSION 17-1(203) 9-19-74 VERSION 17-1(202) 9-19-74 VERSION 17-1(201) 8-8-74 BY JRL BUG #TA# ASSIGNC SCREWED UP WHEN GIVEN CONSTANT EXPRESSION VERSION 17-1(200) 8-5-74 BY JRL BUG #SZ# (CMU =C7=) LPSA WASN'T BEING SAVED IN CLENUP VERSION 17-1(201) 9-19-74 VERSION 17-1(199) 7-7-74 BY RHT MANY EDITS FOR RECGC VERSION 17-1(198) 7-7-74 VERSION 17-1(197) 7-7-74 VERSION 17-1(196) 7-7-74 VERSION 17-1(195) 7-7-74 VERSION 17-1(194) 7-7-74 VERSION 17-1(193) 7-7-74 VERSION 17-1(192) 7-7-74 VERSION 17-1(191) 7-7-74 VERSION 17-1(190) 7-5-74 BY RHT BUG #SS# RECORD INDXED TEMPS AC NOT IN ACKTAB VERSION 17-1(189) 6-2-74 BY RHT MODIFY RCBIT0 VERSION 17-1(188) 5-30-74 BY RLS BUG #SN# ALLOW RECURSIVE EXPR!TYPE CALLS VERSION 17-1(187) 5-29-74 BY RHT BUG #SG# EMITER WAS MODIFYING ADCONS VERSION 17-1(186) 5-27-74 BY RHT MARK RECORD ARRAYS AS SUCH IN THE PD LVI VERSION 17-1(185) 5-27-74 VERSION 17-1(184) 5-27-74 BY RHT ADD DEREFERENCE AT PRST FOR RECORD PROCEDURES VERSION 17-1(183) 5-5-74 BY RHT BUG RW FIX TO BUG FIX #RNR VERSION 17-1(182) 4-12-74 VERSION 17-1(181) 4-12-74 VERSION 17-1(180) 4-12-74 VERSION 17-1(179) 4-12-74 VERSION 17-1(178) 4-12-74 VERSION 17-1(177) 4-12-74 VERSION 17-1(176) 4-12-74 VERSION 17-1(175) 4-12-74 VERSION 17-1(174) 4-8-74 BY RHT %BI% -- ADDED MINOR CHANGES IN LVIOUT VERSION 17-1(173) 3-26-74 BY JFR ADD WRITEON RUNTIME TO LIBFN LIST VERSION 17-1(172) 3-19-74 BY RHT LOOK OVER WITH RLS VERSION 17-1(171) 3-17-74 BY RLS INSTALL TENEX VERSION 17-1(170) 3-16-74 BY RHT BUG #RN# PROTECTACS LOSSAGE VERSION 17-1(169) 2-22-74 BY RHT BUG #RJ# ALWAYS PUT OUT LVI FOR SETS VERSION 17-1(168) 2-5-74 BY HJS BUG #RA# ALLOW TEXT PAST END OF PROGRAM VERSION 17-1(167) 1-29-74 BY HJS BUG #QV# ADD ASGOFF TO TURN OFF SPECIAL ASSIGNC SCANNING VERSION 17-1(166) 1-28-74 BY RHT SHORTEN LONG ERROR MESSAGE (ER24) VERSION 17-1(165) 1-27-74 BY JRL BUG #QT# GIVE BETTER RECOVERY FOR EXTRA ELSE'S VERSION 17-1(164) 1-25-74 BY RHT FIX TYPO IN BUG QK VERSION 17-1(163) 1-16-74 BY RHT BUG #QK# REQUIRE RUNTIMEROUTINE INITIALIZATION VERSION 17-1(162) 1-16-74 BY RHT BUG #QJ# PD WRONG FOR SG ITEMVAR ARRAY VERSION 17-1(161) 1-16-74 VERSION 17-1(160) 1-11-74 BY JRL CMU CHANGE SPACE ALLOCATION BLOCK SIZE VERSION 17-1(159) 1-11-74 VERSION 17-1(158) 1-11-74 VERSION 17-1(157) 1-11-74 VERSION 17-1(156) 1-6-74 BY KVL ADD %BC% ALL THE STUFF ON PGS 32 AND 33 -- BAIL SYM OUTPUTING VERSION 17-1(155) 12-7-73 BY JRL REMOVE STANFORD SPECIAL CHARACTERS(WHERE POSSIBLE) VERSION 17-1(154) 12-2-73 BY RHT BUG #PK# MAKE START CODE DO REMOPS VERSION 17-1(153) 11-29-73 BY RHT EXPAND EXPLANATION OF AN ERROR MESSAGE VERSION 17-1(152) 11-25-73 VERSION 17-1(151) 11-25-73 BY JRL FEAT %AN% ALLOW REQUIRE TO USE CONSTANT EXPRESSIONS VERSION 17-1(150) 11-25-73 BY RHT FEAT %AL% OUTER BLOCK LOOKS LIKE A PROCEDURE VERSION 17-1(149) 11-25-73 BY KVL IMPROVE CODING STYLE IN REQUIRE ERROR!MODES LINK TO DSPATC VERSION 17-1(148) 11-24-73 BY RHT FEAT %AM% ALLOW USER TO SPECIFY INIT PHASE VERSION 17-1(147) 11-24-73 BY RHT GET VERSION BACK VERSION 17-1(146) 11-24-73 VERSION 17-1(145) 11-10-73 BY KVL INSERT LOG ERR UUO STUFF VERSION 17-1(144) 11-10-73 VERSION 17-1(143) 10-31-73 BY HJS BUG #OS# DETECT UNDECLARED ARGUMENT TO CVMS VERSION 17-1(142) 10-30-73 BY RHT BUG #OB# SDFLTS NEEDED TO DO CLRSET VERSION 17-1(141) 10-23-73 BY JRL FEATURE %AG% ITEM!START STUFF VERSION 17-1(140) 9-27-73 BY KVL %AC% REMOVE GLOBAL DECL OPTION IN ERROR RECOVERY VERSION 17-1(139) 9-27-73 VERSION 17-1(138) 9-21-73 BY HJS INHIBIT LST FALSE PART OF CONDITIONAL COMPILATION VERSION 17-1(137) 9-19-73 BY HJS ADD CVPS AND EVALREDEFINE VERSION 17-1(136) 9-1-73 BY RHT FEATURE %AA% -- SPROUT DEFAULTS VERSION 17-1(135) 8-16-73 BY jrl REMOVE REFERENCES TO LEP SWITCH VERSION 17-1(134) 8-12-73 BY JRL BUG #NQ# STRING ITEMVAR IS NOT A STRING VERSION 17-1(133) 8-12-73 VERSION 17-1(132) 7-26-73 BY RHT **** VERSION 17 **** VERSION 16-2(131) 7-22-73 BY JRL BUG #KU# BAD FIX, ARRAY ITEMS SHOULD NOT BE OWN VERSION 16-2(130) 7-14-73 BY RHT ADD AN APPL$Y,SETIP,SETCP TO LIBTAB VERSION 16-2(129) 7-12-73 BY JRL ADD REQUIRE BUCKETS VERSION 16-2(128) 7-12-73 VERSION 16-2(127) 7-12-73 VERSION 16-2(126) 7-12-73 VERSION 16-2(125) 7-12-73 VERSION 16-2(124) 6-20-73 BY JRL BUG #MS# LET NOT WORKING WHEN RIGHT SIDE A TRIGGERER VERSION 16-2(123) 6-20-73 VERSION 16-2(122) 6-20-73 BY HJS IFCR, REDEFINE, EVALDEFINE, AND ASSIGNC IMPLEMENTATION VERSION 16-2(121) 5-9-73 BY HJS REMOP STRING CONSTANTS VERSION 16-2(120) 5-7-73 BY JRL ADD ERRMSG FOR BAD CONTEXT ELEMENT SYNTAX VERSION 16-2(119) 5-4-73 VERSION 16-2(118) 5-4-73 VERSION 16-2(117) 5-4-73 VERSION 16-2(116) 4-23-73 VERSION 16-2(115) 4-23-73 BY RHT CHANGE PROC DESC FOR PROC ARGS VERSION 16-2(114) 4-23-73 VERSION 16-2(113) 4-22-73 BY RHT FIX UNDISCOVERED LVI BUG VERSION 16-2(112) 4-21-73 BY RHT BUG #MC# VERSION 16-2(111) 3-22-73 BY RHT ADD DEFAULT VALUES FOR PARAMS VERSION 16-2(110) 3-20-73 BY RHT CHANGE FORMAL SEMBLK DELETION VERSION 16-2(109) 3-19-73 BY HJS ALLOW TEMPORARY OVERRIDING OF NULL DELIMITERS MODE VERSION 16-2(108) 3-13-73 BY JRL REMOVE SLS,WOM,NODIS,GAG CONDITIONAL VERSION 16-2(107) 3-7-73 BY KVL ADD ACCESS CONSTRUCT FEATURE VERSION 16-2(107) 3-6-73 BY JRL ADD ALLGLOBAL REQUIRE VERSION 16-2(106) 3-5-73 BY JRL ADD OKSTAC TO DCLBEG VERSION 16-2(105) 2-27-73 BY JRL REMOVE ..RVAL FROM LIBTAB VERSION 16-2(104) 2-21-73 BY RHT ADD EXEC TYPMSG (P19) FOR REQUIRE STC MESSAGE VERSION 16-2(103) 2-12-73 BY JRL ADD ..RVAL TO LIBTAB VERSION 16-2(102) 1-28-73 BY JRL REMOVE BOUND FROM SYNTAX VERSION 16-2(101) 1-26-73 BY JRL ADD INCONT TO LIBTAB VERSION 16-2(100) 1-26-73 BY JRL ADD ERRMSG FOR SAMEIV AND IN!CONTEXT VERSION 16-2(99) 1-25-73 BY JRL HALF-KILL ITEMS WITH NOS. < 20 VERSION 16-2(98) 1-25-73 BY JRL MOD ERRMSG ERR112 TO INCLUDE ? VERSION 16-2(97) 1-24-73 BY KVL INSTALL ENTENT EXEC, MAKING DUMMY SYMBOLS TO ENTRY UNNECESSARY VERSION 16-2(96) 1-9-73 BY RHT BUG #KT# TYPO IN UP VERSION 16-2(95) 1-9-73 BY RHT BUG #KY# ALLOW GLOBAL INTERNAL SYMBOLS TO GO OUT ALWAYS VERSION 16-2(94) 1-9-73 BY RHT BUG #KX# NEED ALLSTO BEFORE BEXIT VERSION 16-2(93) 1-8-73 BY JRL BUG KW DON'T ALLOW INTERNAL OR EXTERNAL ITEM DECLARATIONS VERSION 16-2(92) 1-8-73 VERSION 16-2(91) 1-8-73 VERSION 16-2(90) 12-13-72 BY HJS FIX RACE CONDITION WHERE MACROS AND CONDITIONAL COMPILATION END SIMULTANEOUSLY VERSION 16-2(89) 12-11-72 BY HJS ENDC PARSER SWITCH TRIGGER IN WHILEC, CASEC, FORC, AND FORLC BODIES VERSION 16-2(88) 12-2-72 BY HJS SAVE VALUE OF BITS DURING CONDITIONAL COMPILATION AND MACRO DEFINITION VERSION 16-2(87) 11-30-72 BY RHT ADD LIBTAB ENTRIES FOR POLLING VERSION 16-2(86) 11-28-72 BY RHT ADD CODE FOR CLEANUPS VERSION 16-2(85) 11-24-72 BY RHT BUG #KM# TYPO MESSED UP POLISH FIXUP FOR EXT PD VERSION 16-2(84) 11-21-72 BY JRL BAD JRST IN INMAIN VERSION 16-2(83) 11-20-72 BY KVL REMOVE ER51 - MEANINGLESS MSG. IF YOU WANT IT, SEE ME. VERSION 16-2(82) 11-19-72 BY HJS DLMPSH AND DLMPOP FOR PROPER HANDLING OF DEFINES WITHIN DEFINES VERSION 16-2(81) 11-17-72 BY RHT ADD CALL TO USER INITIALIZATION VERSION 16-2(80) 11-15-72 BY HJS INSERT DEFDLM QSTACK ROUTINES FOR DEFLUK BIT OF FF FOR COMPILE-TIME MACROS WITHIN MACROS VERSION 16-2(79) 11-15-72 BY KVL SURPRESS CODE GENERATION AFTER SERIOUS ERRORS. VERSION 16-2(78) 11-10-72 BY HJS ADD DLMSTG STACK SO MACROS DEFINED WITHIN MACROS WITH CONCATENATION WILL WORK VERSION 16-2(77) 11-10-72 BY JRL ADD ERR MSG FOR PROPS AND LIBTAB ENTRIES VERSION 16-2(76) 11-8-72 BY HJS IMPLEMENTATION OF CHECK!TYPE VERSION 16-2(75) 11-7-72 BY JRL GIVE ERROR MESSAGE BAD USE OF BIND VERSION 16-2(74) 11-2-72 BY RHT BUG #JY# TYPE CHECKING ON MEMORY INDEX VERSION 16-2(73) 11-2-72 BY JRL ADD MAINPR TO LIBTAB VERSION 16-2(72) 10-24-72 BY JRL ADD INMAIN EXEC TO INIT MAINPR VERSION 16-2(71) 10-22-72 BY RHT BUG #JU# FIX UP ACKTAB ENCLOBERMENT BY QUICK!CODE VERSION 16-2(70) 10-20-72 BY RHT BUG #JV# MEMORY TRIED TO USE AC 0 AS INDEX VERSION 16-2(69) 10-20-72 BY RHT PROVIDE EXTRA ENTRY POINTS IN REQINI VERSION 16-2(68) 10-17-72 BY AM HJS IMPLEMENTATION OF DECLARATION FEATURE FOR TYPE CHECKING AT COMPILE TIME VERSION 16-2(67) 10-12-72 BY HJS BUG #JP# AND CVMS IMPLEMENTATION VERSION 16-2(66) 10-10-72 BY KVL FIX ; ELSE RECOVERY VERSION 16-2(65) 10-5-72 BY JRL PREPARE FOR EXPO VERSION 16-2(64) 10-5-72 BY KVL MAKE UNDECLARED IDENTIFIERS AN ERR. VERSION 16-2(63) 9-29-72 BY RHT BUG #JH# FIX TYPO IN REQINI VERSION 16-2(62) 9-27-72 BY HJS FORCE EXECUTION OF BLOCK WHEN A DEFINE IS THE ONLY DECLARATION IN THE BEGINNING OF A BLOCK. VERSION 16-2(61) 9-27-72 BY RHT BUG #JF# MESSAGE PROC LINK GETTING WRONG ADDRESS VERSION 16-2(60) 9-27-72 BY JRL ADD ARYSET,SAFSET EXECS FOR DATUMS VERSION 16-2(59) 9-25-72 BY RHT BUG #IZ# GLOBAL STUFF SHOULD STAY OUT OF PD VERSION 16-2(58) 9-22-72 BY RHT BUG #IV# UNDEC FWRD MESSAGE PROC PD BUG VERSION 16-2(57) 9-21-72 BY RHT MAKE THE LOCN PUT THING INCOR VERSION 16-2(56) 8-24-72 BY RHT ADD CAUSE & INTERROGATE TO XCALL TABLE VERSION 16-2(55) 8-23-72 BY JRL ADD BEXIT CODE FOR CONTEXT VERSION 16-2(54) 8-22-72 BY RHT PREVENT DOUBLE ALLOCATION OF KILL SET VERSION 16-2(53) 8-18-72 BY JRL CHANGE TYPPRO TO HANDLE MATCHING PROCEDURES VERSION 16-2(52) 8-14-72 BY RHT EXEC FOR LOCATION(X) VERSION 16-2(51) 8-14-72 BY RHT EVAL NOW NAMED APPLY VERSION 16-2(50) 8-14-72 BY RHT ADD EXECS FOR MEMORY VERSION 16-2(49) 8-11-72 BY RHT MAKE POLISH FIXUP TO GET AT EXTERNAL PD'S VERSION 16-2(48) 8-11-72 BY JRL ADD REMEMBER ETC TO LIBTAB VERSION 16-2(47) 8-4-72 BY RHT BUG #IT# EXTERNALS IN THE PD VERSION 16-2(46) 8-1-72 BY RHT MAKE KILL SETS REAL SETS VERSION 16-2(45) 7-28-72 BY RHT CHANGE FORKER TO SPROUT VERSION 16-2(44) 7-26-72 BY HJS TURN OFF MACRO EXPANSION WHEN SCANNING FORMAL PARAMETERS. VERSION 16-2(43) 7-25-72 BY RHT FIX THE PD SYMBOL VERSION 16-2(42) 7-24-72 BY RHT PUT FORKER IN LIST OF XCALLED FNS VERSION 16-2(41) 7-24-72 BY RHT PUT OUT SYMBOL FOR PD VERSION 16-2(40) 7-22-72 BY RHT ADD KILL LISTS VERSION 16-2(39) 7-9-72 BY RHT NO PD IF NO DADDY VERSION 16-2(38) 7-5-72 BY DCS BUG #II# DON'T LET DEFINES OUT AS SYMBOLS VERSION 16-2(37) 7-2-72 BY JRL SET LEAPIS IF ANY LEAP FUNCTIONS USED VERSION 16-2(36) 6-25-72 BY DCS BUG #HX# PARAMETERIZE OPCODE FILE NAMES (AND OTHERS) VERSION 16-2(35) 6-21-72 BY RHT CHANGE WAY PDA,,0 SEMBLK IS LINKED VERSION 16-2(34) 6-14-72 BY JRL BUG ##H#S# STRING ITEMVAR PROCS ARE NOT STRING PROCS. VERSION 16-2(32) 6-8-72 BY RHT MAKE ENTRY IN LIBTAB FOR EVAL VERSION 16-2(31) 5-16-72 BY RHT GIVE ERR IF SIMPLE PROC ALLOCATES VERSION 16-2(30) 5-16-72 BY RHT TO HANDLE OWN VARS IN BLOCKS--ENTID VERSION 16-2(29) 5-14-72 BY DCS BUG #HH# BETTER INITIAL CODE IF /H VERSION 15-6(7-28) 4-20-72 LOTS OF THINGS VERSION 15-2(6) 2-21-72 BY HJS THE BRAVE NEW PARSER WORLD VERSION 15-2(5) 2-6-72 BY DCS BUG #GN# UUOS TO START!CODE TABLE, FIX BOUNDARY COND. VERSION 15-2(4) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF VERSION 15-2(3) 2-5-72 BY DCS BUG #GI# ADD CAT ROUTS TO LIBFSN (CHRCAT, ETC.) VERSION 15-2(2) 2-1-72 BY DCS ISSUE NEW STYLE %ALLOC SPACE REQUESTS VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER ; LSTON (GEN) BITD2DATA (EMITTER) ; EMITTER BITS -- PUT DESCRIPTORS IN POSITION TO BE EXAMINED BY $L OPERATIONS ^GENBTS: BIT (NOUSAC,400000) ;DON'T USE D(RH) AS AC # BIT (USCOND,200000) ;USE C(RH) AS 3 BITS OF CONDITION BIT (USADDR,100000) ;USE C(LH) AS DISPLACEMENT PART BIT (USX , 40000) ;USE D(LH) AS INDEX REG BIT (NORLC , 20000) ;RELOCATE NOT! BIT (IMMOVE, 10000) ;IF OPERAND CONSTANT, LOAD IT ANY WAY POSSIBLE BIT (INDRCT, 4000) ;INDIRECT ADDRESSING REQUIRED BIT (JSFIX , 2000) ;JUST DO A FIXUP (DON'T GET SEMANTICS). BIT (NOADDR, 1000) ;NO EFFECTIVE ADDRESS PART BIT (EMADDR,400) ;WE WANT THE ADDRESS OF THIS ENTITY BIT (PNTROP, 200) ;INTERNAL OPERATION INDICATING POINTER INDEXING BIT (FXTWO, 100) ;USE SECOND FIXUP WORD BLOCK 6 ;LEFT OVER BITS BITD2DATA (GENMOV) ;CONTROL BITS PASSED TO GENMOV IN THE RIGHT HALF OF "FF". ;FOR COMMENTS, SEE THE FILE "TOTAL". BIT (INSIST,400000) ;INSIST ON DOING TYPE CONVERSION. ;THE RIGHT HALF OF "B" CONTAINS TYPE BITS. BIT (ARITH,200000) ;INSIST ARGUMENT IS AN ARITHMETIC TYPE. BIT (EXCHIN,100000) ;DO AN EXCHOP ON THE WAY INTO THE ROUTINE. BIT (EXCHOUT,40000) ;DO AN EXCHOP ON THE WAY OUT OF A ROUTINE. BIT (GETD,20000) ;DO A GETAD BEFORE DOING THIS ROUTINE. BIT (SPARE,10000) ;NEGAT__ 10000 ;GET THE OPERAND IN NEGATIVE FORM. BIT (POSIT,4000) ;INSIST ON THE OPERAND IN POSITIVE FORM. BIT (BITS2,2000) ;UPDATE SBITS2 FROM $SBITS2(PNT2) ON WAY OUT. BIT (MRK,1000) ;MARK THE ACCUMULATOR MENTIONED IN D WITH THE ARGUMENT. ;(DONE AT END OF MAIN OPERATION) ;THIS MEANS "GENERATE A TEMP CELL IF NECESSARY." BIT (ADDR,400) ;SAME BIT AS GENERATOR USES. USE THE ADDRESS OF ARG. BIT (REM,200) ;REMOP ON THE WAY OUT. BIT (NONSTD,100) ;NON-STANDARD OPERATION. BIT (SPAC,40) ;WE HAVE A SPECIFIC AC NUMBER IN MIND. BIT (PROTECT,20) ;PROTECT THIS ACCUMULATOR. BIT (UNPROTECT,10) ;UNPROTECT THIS ACCUMULATOR. ;;%DU% ! JFR 1-4-77 BIT (ACESS2,4) ;NEED ACCESS TO 2ND WORD OF DBLPRC BIT (DBL,2) ;NEED A DOUBLE ACCUMULATOR. BIT (INDX,1) ;NEED AN INDEXABLE ACCUMULATOR. BITDATA (STROP) ; BITS TO BE PASSED TO STROP IN A ; SEE STROP FOR MEANINGS OF THESE BITS. ?BPWORD __ 400000 ?LNWORD __ 200000 ?BPFIRST __ 100000 ?ADOP __ 40000 ?SBOP __ 20000 ?UNDO __ 10000 ?STAK __ 4000 ?BPINC __ 2000 ZERODATA (EXEC ROUTINES -- GLOBAL VARIABLES) COMMENT  ADEPTH -- Whenever code is generated to push something onto the System stack (P, usually 17), currently only when an actual parameter is put on, this is incremented. It is added to the displacement for a formal parameter whenever it is ref- erenced. This allows the access code to get to the right stack element for a parameter, no matter what's on the stack. ADEPTH is decremented when things come off. It is restarted whenever a procedure declaration is encountered (first checked, since it should always be 0 at that point).  ?ADEPTH: 0 ;APARNO -- a count of the number of non-string parameters in ; the current procedure -- used to set up the $NPRMS word ; in the 2d Semblk for the procedure ; Left half contains the number of VALUE LONG params ; (hence extra words on P stack) ?APARNO: 0 ;DEFRN1 -- Semantics of first formal macro param in VARB-Ring ; while scanning macro params. Used to release all the ; Semblks for these params when done with them. ?DEFRN1: 0 COMMENT  FALLOC -- Semantics of a [0] integer constant, created the first time the word FALSE appears in source -- FALSE thenceforth equated to this [0] constant, since the two are internally equivalent -- see BFAL routine  ?FALLOC: 0 ;GLOBCNT -- used in ENTID to count # global items declared ?GLOBCNT: 0 ;LENCNT -- AOS'ed whenever substring operation is begun, SOS'ed ; when it is complete. BINF (INF same as length(str) EXEC) checks ; this to make sure there's a string to take the length of. ?LENCNT: 0 ;LENSTR -- QSTACK descriptor -- each entry is Semantics of a ; string being SUBSTRd. Kept here for convenience of BINF, ; so that it doesn't have to search up the stack for it. ?LENSTR: 0 ;NULLOC -- Semantics of "", for BNUL (NULL equivalent to "" EXEC) ?NULLOC: 0 ;SEE FALLOC, TRULOC ;OPCODE -- for binary operations, proper opcode (and control bits), ; fetched from one of the OP tables (PMTAB, TDTAB, MXMNTB) via the ; class code in the production which called the EXEC. Used as tem- ; plate for output instruction. Stored in OPCODE for convenience ?OPCODE: 0 ;SDEPTH -- ADEPTH-type count for String stack -- bumped not only for ; actual params, but also for String Procedure results, other ; String operations which use the stack. ?SDEPTH: 0 ;SPARNO -- APARNO-type count of String formals -- it's possible that ; this is doubled before use, since there are two words for each ; String descriptor. See PROCED, ENTID for uses. ?SPARNO: 0 ;THISE -- Set by ECHK EXEC, remembers type of expression, since two ; class codes are passed in from PARSER ; (e.g., EXEC @E ECHK @class randomexec) ?THISE: 0 ;TRULOC -- Semantics of [-1], used by BTRU (TRUE equivalent to 0 EXEC) ?TRULOC: 0 TABLEDATA (EXEC ROUTINES -- GLOBAL VARIABLES) COMMENT  LIBTAB -- table of fixups (current ends of chains) for routines called by SAIL programs to accomplish complicated operators (CAT, SUBSTR, ARRMAK, etc.) -- the LIBFSN macro, with the appropriate definition of the FN macro, puts out a symbolic index into this table for each name mentioned (R&ROUTNAME), and a word of table to hold the fixup. It is used again below (LIBNAM) to create a table of corresponding External RADIX50 request words which will be used in DONES to put out the chain requests. The XCALL and LPCALL macros are used to put out (fixup chained) calls to these routines.  DEFINE LIBFSN < FN ;STRING CONCATENATIONS. FN ;INTEGER&STRING FN ;STRING&INTEGR FN ;INTEGR&INTEGR FN ;STRING&STRING, 2D ARG FIRST FN ;SUBSTRING (FOR) FN ;SUBSTRING (TO) ; FN ;EXTINCT (USED TO BE SUBSTRING INF) FN ;CONVERT FIRST CHAR OF STRING TO INTEGER FN ;CONVERT LOW ORDER 7 BITS TO STRING FN ;EXPONENTIATION FN ;FLOATING ARG, INTEGER EXPONENT. FN ;LONG REAL ARG, INTEGER EXPONENT FN ;INTEGER ARG,FLOATING EXPONENT. FN ;FLOATING ARG, FLOATING EXPONENT. FN ;LONG REAL ARG, LONG REAL EXPONENT FN ($PDLOV) ;THIS IS HOW TO CAUSE PDLOV UNDER SKIPL FN ;MARK THE ARRAY PUSHDOWN STACK. FN ;MAKE AN ARRAY (PARAMS IN STACK) FN ;RELEASE ARRAYS BACK TO LAST MARK ON STACK. FN ;CALL LEAP! FN ;THIS IS REF TO A WORD WHICH IS XWD 3, ptr to ; BASE OF DATUM TABLE. FN ;DATUM(X) WAS NULL, WHEN AN ARRAY WAS EXPECTED. ;; \ur#6 require verify!datum FN <$$DERR> ;INCORRECT ITEM TYPE FOR DATUM FN ;BYTE POINTER FOR TYPEIT CODES ;; \ur#6\ FN ;THE PROPS BYTE POINTER POINT 9,INFOTAB(3),35 GLOC < FN ;GLOBAL PROPS FN ;GLOBAL DATUM FN <.MES1> FN <.MES2> FN >;GLOC FN ;BIND PD TO ITEM FN ;COPY PROC ITEM FN ;-1(P)_DATUM(-1(P)) FN ;INTERP CALLER FN ;SPROUTER FN ;CAUSES EVENTS FN ;INTERROGATE FUNCTION FN ;INITIALIZE PROCESSES FN ;BLOCK EXITER FN ;STACK UNWINDER FN ;CASE STATEMENT INDEX OUT OF BOUNDS FN ;REMEMBER ALL FN ;FORGET ALL FN ;RESTORE ALL FN ;REMEMBER FN ;FORGET FN ;RESTORE FN <.INCON> ;IN!CONTEXT FN ;C:VAR FN <.SUCCE> ;SUCCEED (FOR MATCH. PROCS) FN <.FAIL> ;FAIL FN <.UINIT> ;USER INITIALIZATIONS FN ;DO DEFERED INTERRUPT FN ;SET 0 WHEN HAVE AN INTERRUPT FN ;USED WITH SPROUT APPLY FN ; FN ; FN ;WRITEON RUNTIME REC < FN <$RERR> ;RECORD ACCESS ERROR FN <$REC$> ;SYSTEM RECORD HANDLER >;REC NRC < FN <$CLASS> ;RECORD CLASS CLASS FN <$RECFN> ;THE ROUTINE THAT REPLACES RECUUO >;NRC > DEFINE FN '(X) < ?R'X __ LIBNUM ?LIBNUM __ LIBNUM+1 0 ;FIXUP WORD. > ?LIBNUM__0 ?LIBTAB: LIBFSN ;FIXUPS FOR LIBRARY FUNCTIONS. ; the current procedure -- used to set up the $NPRMS word TABCONDATA (EXEC ROUTINES -- GLOBAL VARIABLES) COMMENT  LIBNAM -- these are the external request symbols for the above-mentioned runtime routines -- see LIBTAB, above  DEFINE FN (X) < RADIX50 60,X > LIBNAM: LIBFSN > COMMENT  TYPTAB, VALTAB, XOTAB These tables are used by the TYPSET, VALSET, XOWSET routines to convert the class codes from the PARSER, specifying which data type, REFERENCE or VALUE type, or modifier (SAFE, etc.) is being requested, to the appropriate TBITS bit. These three routines are, as might be guessed, EXEC routines.  ^TYPTAB: HELITM: ITEM ;ITEM HELITV: ITMVAR ;ITEMVAR 0+SET ;SET LABEL+FORWRD ;LABEL FLOTNG ;REAL INTEGR ;INTEGER STRING ;STRING INTEGR ;BOOLEAN 0+SET+LSTBIT ;LIST XWD SAFE,SET!INTEGR ;KILL!SET 0+SET!FLOTNG ;CONTEXT XOTAB: XWD INTRNL,0 ;INTERNAL XWD SAFE,0 ;SAFE XWD EXTRNL,0 ;EXTERNAL XWD OWN,0 ;OWN XWD RECURS,0 ;RECURSIVE XWD EXTRNL,FORTRAN ;FORTRAN FORWRD ;FORWARD SHORT ;SHORT XWD SIMPLE,0 ;SIMPLE XWD MPBIND,INTEGR ;MATCHING GLOC < GLOBL ;GLOBAL LEAP TYPE. XWD MESSAGE,0 ;MESSAGE >;GLOC NOGLOC < 0 ;TURN ON NO BITS IF NOT GLOBAL 0 ;COMPILER.... >;NOGLOC ;;%DS% ! JFR 8-21-76 XWD CONOK,0 ;EVALUATE AT COMPILE TIME IF ALL ARGS CNST ;;%DU% ! DBLPRC ;LONG (DOUBLE PRECISION) VALTAB: XWD REFRNC,0 ;REFERENCE XWD VALUE,0 ;VALUE XWD VALUE!MPBIND,ITMVAR ;? PARAMETER CHKTAB: XWD RES,0 ; RESERVED XWD BILTIN,0 ; BUILTIN FUNCTION LPARRAY ; LEAP ARRAY XWD SBSCRP,0 ; NORMAL ARRAY XWD DEFINE,0 ; DEFINE PROCED ; PROCEDURE ;;#XH# 2! JFR 7-4-76 PNTVAR ; RECORD!POINTER PNTVAR!SHORT ; RECORD!CLASS ENDDATA SUBTTL EXEC (GENERATOR) INITIALIZATION DSCR GENINI CAL PUSHJ from SAIL Exec RES Initializes variables for whom the EXECS (generators) have main responsibility. Calls RELINI and LEPINI to set up Relfile and Leap variables SEE SAIL Exec, RELINI, LEPINI  ^GENINI: ;;%AL% ! STARTUP SEQUENCE IS ONE SHORTER II__7 ;LONGER STARTUP ;* * * * * * REN < SETOM INHIGH ;WILL BE IN HIGH FIRST IF HISW MOVEI TEMP,1 MOVEM TEMP,HCNT ;DATA STARTS AT 1 IF HISW >;REN MOVEI TEMP,II ;START HERE REN < SKIPE HISW ;TWO-SEGMENT COMPILATION? MOVEI TEMP,400000+II ;YES, CODE STARTS HERE >;REN MOVEM TEMP,PCNT ;;#HH# 5-14-72 DCS (2-2) ACCOUNT FOR UPPER SEGMENT CODE REN < MOVEI TEMP,5-II(TEMP) ;NOW ADJUST INITIAL PD PUSH DATA HRRM TEMP,IPDFIX ;SEE SAIL FOR THIS ARCHBLOCK >;REN ;;#HH# (2-2) Comment  The first words of code are (for main programs) 0 SKIPA ;NON-RPGMODE START 1 SETOM RPGSW ;RPG MODE 2 JSR SAILOR ;INITIALIZE 3 HRLOI RF,1 ;FOR FAKE F LINK 4 PUSH P,RF 5 PUSH P,[PDA,,0] ;PDA OF OUTER BLOCK & USELESS STATIC LINK 6 PUSH P,SP ;REST OF MSCP 7 HRRZI RF,-2(P) ;POINT THERE ; ; MARK TOP AC'S UNUSABLE FOR GENERAL ALLOCATION FOR II IN (RSP,RP,USER,TEMP,LPSA,RF) < SETOM ACKTAB+II> ; ***** THIS CODE MOVED TO RELOUTPUT AREA IN TOTAL PUSHJ P,RELINI ;INITIALIZE LOADER FILE VARIABLES ; ***** ;No RAID on TENEX and $M causes UNDEF GLOBAL loading errors NOTENX < IFN FTDEBUG < MOVE TEMP,BITABLE EXTERNAL $M MOVEM TEMP,$M+3 ;RAID LOC >;IFN FTDEBUG >;NOTENX ; ***** THIS CODE MOVED TO LEAP PUSHJ P,LEPINI ;INITIALIZE LEAP VARIABLES ; ****** POPJ P, REN < DSCR HISET, LOSET, SWIT -- Call to Get Correct PCs into PCNT and HCNT DES Calling HISET makes sure code will go to upper segment. Calling LOSET makes sure it will go to lower segment Calling SWIT does HISET if LOSET was last, LOSET if HISET was last.  ^HISET: SKIPE INHIGH ;ALREADY IN HIGH SEGMENT? POPJ P, ;YES, DONE JRST SWIT ;NO, GO IN ^LOSET: SKIPE INHIGH ;ALREADY IN LOW SEGMENT OR ^SWIT: SKIPN HISW ; IS THIS RELEVANT? POPJ P, ;YES OR NO SETCMM INHIGH ;IF IN, NOW OUT AND VICE VERSA PUSHJ P,FRBT ;FORCE OUT BINARY IN OTHER SEGMENT MOVE TEMP,PCNT ;EXCHANGE PCS EXCH TEMP,HCNT MOVEM TEMP,PCNT POPJ P, ;DONE >;REN DSCR GETOP, GETADL, GETAD DES Routines to pick things up from symbol table blocks. GETOP is the entry which also picks up the generator stack entry specified by accumulator A.  ^GETAD2: SKIPN PNT2 ERR MOVE SBITS2,$SBITS(PNT2) MOVE TBITS2,$TBITS(PNT2) POPJ P, ^GETAD: JUMPN PNT,GETSTF ;TEST FOR NULL SEMANTICS. ERR ^GETADL: SKIPN PNT,LPSA ;MAKE SURE WE HAVE A GOOD ENTRY ERR GETSTF: MOVE SBITS,$SBITS(PNT) MOVE TBITS,$TBITS(PNT) ;BOTH BITS WORDS POPJ P, BEGIN GENDEC SUBTTL EXECS for typing variables, equating TRUE with -1, etc. DSCR -- SAIL DECLARATION EXECS DES These are the declarations routines. They take care of simple identifier declarations as well as procedures, arrays, etc. If a "BEGIN" is seen, the varb structure recurrs out of the current block, a new one is created, the VARB list is updated to the new block, and a new symbol table bucket is made. The reverse is effected when an "END" is seen which matches a BEGIN which involved declarations. For procedures, a similar thing happens.  DSCR TYPDEC, TYPAR, TYPPRO, etc. PRO TYPDEC TYPAR TYPPRO TYPR1 PRST DES The routines to "type" an entity and return an appropriate parser token. Thus, the parser can be aware of the types of user identifiers. This speeds up operations somewhat, and means that the parser can do much of the "semantic" type-checking.  ^TYPDEC: HRLI A,CLSIDX ;ALL VARIABLES ARE CLASS MEMBERS TLNE TBITS,CNST ;a constant ? JRST MYCON TLNE TBITS,SBSCRP ;ARRAY? JRST ARLO ;YES TRNE TBITS,ITEM+ITMVAR+PROCED JRST TYPDES ;DESCRIMINATE HRRI A,TICTXT TRNE TBITS,FLOTNG TRNN TBITS,SET CAIA POPJ P, HRRI A,TIST ;SET TRNE TBITS,SET POPJ P, REC < TRNE TBITS,PNTVAR ;CHECK FOR RECORD CLASS ID TRNN TBITS,SHORT ;CLASS IS SHORT PNTVAR JRST .+3 ;NOPE HRRI A,TIRC ;IT IS A RECORD CLASSID POPJ P, >;REC HRRI A,TIVB NOREC < TRNE TBITS,INTEGR+FLOTNG+DBLPRC >;NOREC REC < TRNE TBITS,INTEGR+FLOTNG+DBLPRC+PNTVAR >;REC POPJ P, HRRI A,TISV ;STRING VARIABLE TRNE TBITS,STRING POPJ P, HRRI A,TILB ;LABEL TRNE TBITS,LABEL POPJ P, TROUBL: HRRI A,TI ;UNDECLARED IDENTIFIER POPJ P, TYPDES: HRRI A,TIPR ;PROCEDURE TRNE TBITS,PROCED POPJ P, HRRI A,TIIT ;ITEM TRNE TBITS,ITEM POPJ P, HRRI A,TITV ;ITEMVAR TRNE TBITS,ITMVAR POPJ P, JRST TROUBL ARLO: HRRI A,TIAR ;ARITHMETIC OR ITEM ARRAY. POPJ P, ;ARITHMETIC OR ITEM ARRAY MYCON: HRRI A,TICN ;ARITHMETIC CONTSTANT TRNE TBITS,STRING ;MIGHT BE STRING HRRI A,TSTC ;STRING CONSTANT. POPJ P, ^TYPAR: ;TYPE AN ARRAY ^TYPPRO: TDZA B,B ;INDEX INTO GENRIG,PARIG ^TYPR1: MOVEI B,1 SKIPN LPSA,GENRIG(B) ;SEMANTICS ERR ,1,<[TRO TBITS,INTEGR JRST TYPESS]> TYA1: PUSHJ P,GETADL ;GET GOOD BITS TLNE TBITS,MPBIND ;MATCHING PROCEDURE TLNN FF,LPPROG ;AND FOREACH IN PROGRESS CAIA POPJ P, TRZ TBITS,PROCED ;TURN OFF PROCEDURE TLZ TBITS,-1 TRNN TBITS,ALTYPS ;ANYTHING THERE? TYPER: JRST [HRLI A,CLSIDX ;WE FAKE AN INTEGER HRRI A,TIVB JRST TYPESS] PUSHJ P,TYPDEC ;TYPE BIT TYPESS: MOVEM A,PARRIG(B) ;PUT DOWN THE ANSWER POPJ P, ^PRST: SKIPN PNT,GENRIG POPJ P, ;PROCEDURE WAS UNTYPED.... MOVE TBITS,$TBITS(PNT) ; TYPE. ;;#HS# JRL 6-14-72 A STRING ITEMVAR IS NOT A STRING TRNE TBITS,ITMVAR!ITEM JRST REMOP ;;#HS# REC < NORGC < TRNE TBITS,PNTVAR ;A RECORD PROCEDURE?? JRST [ EMIT JRST REMOP ] ;DEREFERENCE IT >;NORGC >;REC TRNE TBITS,STRING ;IF OF TYPE STRING, COMPLAIN. JRST SUBIT ;DOWN IN TOTAL -- SUBTRACTS FROM STACK. JRST REMOP DSCR TYPSET, VALSET, XOWSET, etc. PRO TYPSET XOWSET VALSET HELAR2 HELAR1 HELARY CLRSET PRSET DES EXECS to collect type bits as they are specified The standard mechanisms for entering variables. Little routines are called to turn on the right bits in the "BITS" word for ENTERS to eventually use  ;RECORD ANY MODIFIERS ON THE DECLARATIONS. ;CALLED WITH CLASS INDEX TYPE IN REGISTER B. ^XOWSET: SKIPA A,XOTAB(B) ;PICK UP TABLE ENTRY ^VALSET: MOVE A,VALTAB(B) ;INDEXED BY "B" PASSED FROM PARSER IORM A,BITS POPJ P, ;RETURN ^ARYSET: SKIPA A,[LPARRAY] ^SAFSET: MOVEI A,SAFE ;SAFE BIT IORM A,BITS ;SAVE IT POPJ P, ^HELAR2: MOVE B,BITS ;; #KU# DON'T MAKE ARRAY ITEMS OWN TRO B,ITEM ;SO HELSPC WILL KNOW NOT TO MAKE OWN PUSHJ P,HELSPC ;SPECIAL FOR ARRAY ITEMS. TDZA B,B ;ITEM ....... ^HELAR1: MOVEI B,1 ^HELARY: MOVEI A,LPARRAY ;SAY A LEAP TYPE ARRAY. IORM A,BITS ;AND FALL THROUGH TO TYPE IT. ^HELSET: ^TYPSET: MOVE A,TYPTAB(B) ;ORDINARY TYPES. IORB A,BITS MOVEM A,ARYBIT ;AND RECORD SHOULD AN ARRAY BE DECLARED. POPJ P, ^CLRSET: SETZM BITS ;ZERO FOR A NEW TYPE REC < SETZM QRCTYP SETZM URCIPR SETZM RCLASS >;REC POPJ P, ^PRSET: MOVEI A,PROCED IORM A,BITS POPJ P, ; ****** ; STARY, ENTARY, Array declaration routines, were moved to ARRAY code ; ****** 11/24/70 MOVEM A,PARRIG(B) ;PUT DOWN THE ANSWER DSCR TCON, BTRU, BFAL, BNUL, BINF PRO TCON DES kludges to make TRUE, FALSE, NULL, and INF work right TRUE canonically -1, so a constant is created (once), and Semantics rtnd FALSE equivalent to 0 NULL equivalent to "" INF same as LENGTH(innermost String being SUBSCRd -- else error)  ^TCON: JRST .+1(B) ;CALL CORRECT ROUTINE. JRST BINF ;INF OPERATOR. JRST BNUL ;NULL ^BTRU: SKIPA C,[XWD -1,TRULOC] ^BFAL: MOVEI C,FALLOC PUSHJ P,GETITC ;GET THE CONSTANT. RETRT: MOVEM PNT,GENRIG POPJ P, ^BTRU1: HRROI C,TRULOC ;FOR TRUE GETITC: SKIPE PNT,(C) ;IS THERE A VALUE ALREADY?? POPJ P, ;YES -- RETURN IT. PUSH P,BITS HLRE A,C ;THIS IS 0 OR -1 PUSHJ P,CREINT MOVEM PNT,(C) POP P,BITS ;RESTORE POPJ P, ^BNUL: SKIPE PNT,NULLOC JRST RETRT PUSH P,BITS PUSH P,PNAME PUSH P,PNAME+1 SETZM PNAME+1 SETZM PNAME PUSHJ P,STRINS MOVEM PNT,NULLOC POP P,PNAME+1 POP P,PNAME POP P,BITS JRST RETRT ^BINF: SKIPN LENCNT ;ARE WE INSIDEA SUBSTRING OPERATION?? ERR (,1,BFAL) HLRZ A,LENSTR ;LEFT HALF POINTS TO TOP OF QPUSH STACK. SKIPGE A,(A) ;NEG IF INF. WITHIN SUBLIST SELECTOR JRST LINF ;LIST INFIN. LOCATED IN LEAP MOVEM A,GENLEF+1 ;SET UP FOR LENGTH JRST LLEN1 ;MODIFIED FORM OF LENGTH. DSCR TWID10, ECHK, ESET PRO TWID10, ECHK, ESET DES The "TWIDDLERS" which craftily manipulate the semantics stack entries. They are used to move things around when no other generators need be called, or when convenience warrents.  ^TWID10: MOVE A,GENLEF+1 ;THIS MOVES FROM ENTRY 1 MOVEM A,GENRIG ;TO ENTRY 0. POPJ P, ;EXAMPLE -- PRODUCTION "XID" ;NOW FOR THE GENERALIZED EXPRESSION CHECKER. PASSED IS AN INDEX.... ^ECHK: JRST @.+1(B) ;GO DO RIGHT THINGS. JRST CPOPJ ;REGULAR ARITH EXPRESSION. JRST LEVBOL ;BOOLEAN EXPRESSION .. CONVERT TO INTEGER. JRST LEAVE ;ASSOCIATIVE EXPR. -- CONVERT TO ITEM .. ; SAVE CLASS INDEX FOR PRODUCTIONS WHICH REFER TO TWO (FIRST) ^ESET: MOVEM B,THISE ;SAVE INDEX IF THIS CLASS POPJ P, ;HARDLY WORTH THE CALL ; (SHOULD HAVE WRITTEN?) DSCR FDO1, FDO2 PRO FDO1 FDO2 DES LEAP function calling routines -- dipatch on class to proper LEAP routine.  ^FDO1: JRST @.+1(B) JRST ISTRIP ;ISTRIPLE JRST SLOP ;STRING LOP JRST ECVN ;CVN JRST [SKIPN PNT,GENLEF+1 JRST STCNT MOVE TBITS,$TBITS(PNT) TRNN TBITS,STRING!INTEGR JRST STCNT ;LENGTH OF SET. JRST LLEN ;STRING LENGTH ] REPEAT 2 , ;BYTE POINTER THINGS. ^FDO2: JRST @.+1(B) SELET SELET SELET ;FIRST,SECOND,THIRD STUNT ;COP ECVI ;CVI SUBTTL EXECS for Handling Block Levels, Entering Variables DSCR DWN, BLOCK, BLNAME, ENTID, UP, NAMCHK, etc. PRO DWNA DWN BLOCK BLNAME ENTID ENDDEC UP1 UP2 NAMCHK UPWOM DES These EXECS handle the declarations of a Block, from recursion of lexical state at BEGIN and END, to the actual entry of locals, to the checking of Block names. SEE comments following this DSCR for more information.  Comment  These are the routines to process the entering and leaving of lexical levels. DWN is called when a BEGIN is seen. It merely clears the boards in case some declarations come along. BLOCK is called if it develops that this block is going to have declarations. The lexical level is incremented, and a new hash bucket is made. The block entry in the semantic stack is flagged as "declarations done in this block". BLNAME is called if the block is going to have a name. This is independent of whether it has declarations or not. If there are no declarations, this is merely the name of a compound block. ENTID is called to enter identifiers in the block. It basically calls ENTERS. But there is a lot of bookkeeping to do -- allocate item numbers, flag the block if arrays are declared, etc. ENDDEC is called when all declarations are done. This puts out an ARMRK if arrays were declared, etc. UP1 or UP2 is called when the block is exited. The block header is placed in a "block list" which is scanned at allocation time (end of procedure). Symbols, etc. are put out at that time. NAMCHK is called to check to see if the respective BEGIN END pairs have corresponding names. PACDO is called to protect acs for the duration of the block  ;COME HERE WHEN YOU SEE A BEGIN ^DWN: ;;%DH% JFR 11-21-75 GETBLK GENRIG ;FIRST BLOCK SEMBLK GETBLK ;LPSA=SECOND BLOCK SEMBLK MOVE TEMP,GENRIG ;TEMP=FIRST BLOCK SEMBLK HRLZM LPSA,%TLINK(TEMP) ;POINT FIRST AT SECOND MOVE A,TRKBEG HRLI A,(TEMP) MOVEM A,%TLINK(LPSA) ;POINT SECOND AT FIRST,,OUTER MOVEM LPSA,TRKBEG ;RECORD CURRENT MOVEI A,$PNAME-1(LPSA) PUSH A,FPAGNO ;PAGE PUSH A,ASCLIN ; AND LINE OF BEGIN ;;#WB# 2! JFR 12-8-75 HRLZ A,PCNT MOVEM A,$VAL2(TEMP) ;REMEMBER FWA CODE ;;#WK# 1! JFR 2-25-76 HLRM A,$ADR(LPSA) ;HERE, TOO, TO ESCAPE THE CLUTCHES OF ENDDEC+5 BAIL< HRRZ A,BCORDN HRRM A,$VAL2(LPSA) ;COORDINATE >;BAIL ;;%DH%^ SETOM NODFSW ; SET FLAG TO DEFER PROCESSING OF DEFINES ; UNTIL A BLOCK HAS BEEN EXECUTED. ^DWN1: SETZM BITS ;IN CASE A CONSTANT WAS ENTERED SETZM GENRIG+1 ;WHILE WE WERE AWAY!!! BAIL< SKIPLE BAILON PUSHJ P,BCROUT ;A NEW COORDINATE FOR EACH BEGIN >;BAIL POPJ P, ;ALL DONE ^OFFDEF: SETZM NODFSW ; TURN OFF FLAG WHICH DEFERS THE PROCESSING POPJ P, ; OF DEFINES UNTIL A BLOCK HAS BEEN ; EXECUTED. ^BLOCK: SETZM NODFSW ; TURN OFF FLAG WHICH CAUSES THE DEFERMENT ; OF DEFINE PROCESSING. AOS LEVEL REC < QPUSH (RCLPDL,[-1]) ;MARK THE REC CLASS LIST PDL >;REC MOVE A,VARB ;SAVE OLD CONTENTS. SETZM VARB ;RESTART VARB. SKIPN LPSA,GENLEF+1 ;"BLOCK" BLOCK THERE? GETBLK ; NO -- GET ONE. SKIPN QQFLAG ;IS THIS THE FIRST BLOCK WITH DECL'S? HRRZM LPSA,QQBLK ;YES, STORE IT FOR UNDEC SETOM QQFLAG ;**** QQFLAG WILL HAVE TO BE INCLUDED IN THE INITIALZATION CODE EVENTUALLY**** MOVE TEMP,PCNT HRLM TEMP,$VAL2(LPSA) ;SAVE ADDRESS OF FIRST WORD ;;#%%# DEFAULT NAME CREATION TRANSFERED TO BAISYM 11-7-74 JFR BAIL< SKIPN BAILON JRST .+3 SKIPN $PNAME(LPSA) ;ALREADY HAVE A NAME? AOS NMLVL ;NO. UP A DDT LEVEL--NAME WILL BE GIVEN LATER >;BAIL HRROM LPSA,GENRIG+1 ;FLAG THAT DELCARATIONS HAVE BEEN DONE. PUSHJ P,RNGVRB ;PUT ON THE VARB RING HRL A,TTOP ;GET OLD TTOP MOVEM A,$ADR(LPSA) ;SAVE TTOP,,VARB. MOVEW (<$SBITS(LPSA)>,LEVEL) ;SAVE CURRENT LEVEL HRRM LPSA,TTOP ;NEW ONE HRRZ TEMP,NMLVL ;PICK IT UP HERE IN CASE BLNAME DOESN'T HRRM TEMP,$VAL2(LPSA) ;AND STORE IT IN DDT LEVEL LOCATION PUSHJ P,MAKBUK ;MAKE A NEW SYMBOL BCKET MOVE LPSA,SYMTAB ; GET NEW BUCKET MOVE TEMP,GENRIG+1 ; GET THE BLOCK HRRM LPSA,%TBUCK(TEMP) ; STORE BUCKET FOR LATER HASH OF IDENTS JRST SHASH ;HASH AGAIN GIVEN THE NEW BUCKET ^CSNAME: TLO FF,FFTEMP ;NAMED CASE STATEMENT SETZM BITS ;DUPLICATE INITIAL CODE MOVE PNT,GENLEF ; BECAUSE MOVE LPSA,GENLEF+1 ; WE ALREADY HAVE A CASE BLOCK JRST FOXX ; LINK IT TO STRING RING AND CONTINUE ^BLNAME: TLZ FF,FFTEMP ;NAMED BLOCK,CPD STMT SETZM BITS MOVE PNT,GENLEF ;POINTER TO NAME CONSTANT. SKIPN LPSA,GENRIG GETBLK ;GET A BLOCK. FOXX: PUSHJ P,RNGSTR ;PUT ON THE STRING RING TLNE FF,FFTEMP ;CASE STMT? JRST CSVER ;YES, NO LABEL ISSUED AOS TEMP,NMLVL ;DDT (BLOCK NAME) LEVEL HRL TEMP,PCNT ;LOCATION OF FIRST WORD MOVEM TEMP,$VAL2(LPSA) ;STORE IN BLOCK BLOCK CSVER: MOVEI A,$PNAME-1(LPSA) PUSH A,$PNAME(PNT) ;RECORD NAME. PUSH A,$PNAME+1(PNT) TLNN FF,CREFSW ;CREFFING? JRST NOCRW ;NO MOVEI A,15 PUSHJ P,CREFOUT ;BLOCK NAME COMING. PUSHJ P,CREFASC ;AND CREF THE ASCII NAME OF BLOCK. NOCRW: TLNN FF,FFTEMP ;CASE? TLNN FF,TOPLEV ;AT TOP LEVEL? POPJ P, ;NO MOVEI LPSA,IPROC+$PNAME-1 ;PUT IN PROGRAM NMAE. PUSH LPSA,$PNAME(PNT) PUSH LPSA,$PNAME+1(PNT) ;;%DE% ! JFR 10-25-75 USED TO JRST MAKT POPJ P, ^PACDO: MOVE LPSA,GENLEF+1 ;PICK UP AC NO TO SAVE MOVE D,$VAL(LPSA) ; CAIL D,0 CAILE D,17 ERR ,7 ANDI D,17 ;IN CASE THE FOOL CONTINUES SKIPL B,ACKTAB(D) JRST .+3 MOVE D,D ;FOR ERR UUO ERR ,7 PUSHJ P,STORZ ;CLEAR THE AC HRROS ACKTAB(D) ;PROTECT IT HRLZI A,1 ;;#RN# ! USED TO BE -1(D) LSH A,(D) ;ORING MASK MOVE LPSA,TTOP ORM A,$TBITS(LPSA) ;MARK BLOCK SEMBLK MOVEI A,12 MOVEI B,4 CNT1FA: SKIPL ACKTAB(A) SOJLE B,ENGHAC SOJGE A,CNT1FA ERR ,1 ENGHAC: POPJ P, ^ENTID: ORDENT: SKIPN PNT,NEWSYM JRST ENWAY ;NOT DEFINED BEFORE MOVE TBITS,$TBITS(PNT) ;GET CURRENT SEMANTICS TLNE TBITS,CNST ;DON'T LET CONSTANTS THROUGH ERR ,1 TLNN FF,CREFSW ;ARE WE CREFFING? JRST ENWAY ; NO MOVEI A,7 ;DELETE PREVIOUS ENTRY. PUSHJ P,CREFOUT ENWAY: GLOC < SKIPN ALLGLO ;GLOBAL LEAP ONLY? JRST ENWAY2 ;NO MOVE A,BITS TRNE A,ITEM ;ONLY ITEMS ARE AFFECTED TRO A,GLOBL MOVEM A,BITS ENWAY2: >;GLOC PUSHJ P,ENTERS ;DO THIS FIRST!! MOVE LPSA,NEWSYM PUSHJ P,GETADL ;GET GOOD BITS TLNE FF,PRODEF ;ARE WE SCANNING ID LIST JRST IDLIS ; YES MOVE A,[XWD SAFE,SET+INTEGR] ;CHECK ON KILL SET GUY TDC A,TBITS TDNE A,[XWD SAFE,SET+INTEGR] ;IS IT ?? JRST EN.W1 ;NO TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR!PROCED] ERR EN.W1: TLNE TBITS,SBSCRP ;IF STRING ARRAYS, TURN TRZ TBITS,STRING ;OFF THE STRING PART. TRNE TBITS,ITEM!ITMVAR ;IGNORE DATUM TYPE OF ITEMS ;;%BI% ALSO NO WORRY ABOUT PNTVAR REC < TRZ TBITS,STRING!BOOLEAN!INTEGR!SET!LSTBIT!FLOTNG!PNTVAR >;REC NOREC < TRZ TBITS,STRING!BOOLEAN!INTEGR!SET!LSTBIT!FLOTNG >;NOREC MOVE PNT2,TTOP ;CURRENT BLOCK. ;;#VS# ! JFR 11-9-75 EXTERNALS ARE ALSO NOT DEFINED HERE TLNE TBITS,OWN!EXTRNL ;IF OWN, THEN DONTSAVE BIT JRST IORDON ; SKIPN SIMPSW ;BETTER NOT LET SIMPLE DO ALLOC JRST .+3 ;HE ISNT SIMPLE NOREC < TDNE TBITS,[XWD SBSCRP,SET] ;CHECK FOR BAD GUYS >;NOREC REC < TDNE TBITS,[XWD SBSCRP,SET!PNTVAR] ;CHECK FOR BAD GUYS >;REC ERR ,1,IORDON IORM TBITS,$VAL(PNT2) ;THE "OR" OF ALL SYMBOLS DEFINED. IORDON: GLOC < TRNN TBITS,ITEM ;IF ITEM OR TRNN TBITS,GLOBL ;NOT GLOBAL, THEN GO ON JRST NOGLB TLNE FF,TOPLEV ;IF NOT AT TOP LEVEL TRNE TBITS,STRING!LABEL ;OR IF THESE RIDICULUOUS TYPES. ERR ,1 AOS A,GLOBCNT ;COUNT OF GLOBALS. CAILE A,GLBAR ;WITHIN BOUNDS OF GLOBAL AREA? ERR ,1 HRLM A,$VAL2(PNT) ;AND SAVE. NOGLB: >;GLOC ; FOLLOWING REMOVED TO ALLOW INTRODUCTION OF STRING ITEMS. ; TRNN TBITS,LPARRAY ; JRST [TRNN TBITS,STRING ; JRST .+1 ; TRNE TBITS,ITEM!ITMVAR ; ERR ,1 ; JRST .+1] NOGRUMP: TRNE TBITS,ITEM!ITMVAR!SET ;A LEAP DATA TYPE? SETOM LEAPIS ;TELL WORLD SOMEONE USED LEAP. TRNN TBITS,ITEM ;WAS IT AN ITEM? POPJ P, PUSH P,PNT ;SAVE ITEM SYMBOL POINTER PUSH P,BITS GLOC < TRNE TBITS,GLOBL ;IF A GLOBAL ITEM, THEN MAKE LEFT HALF SOSA A,GITEMNO >;GLOC ;; %AG% LH(ITEMNO) NOW CONTAINS ITEM!START AOS A,ITEMNO ;MAKE A NEW NUMBER FOR IT HRRZS A ;; %AG% AOS ITMCNT ;TOTAL NUMBER OF DECLARED ITEMS PUSHJ P,CREINT ;MAKE AN INEGER OF ITEM NUMBER. MOVE PNT2,PNT PUSH P,A ;SAVE ITEM NUMBER SKIPN PNMSW ;PNAMES GOING NOW ? JRST NOPNM ;NO AOS PNMSW ;INDEX COUNT. PUSHJ P,STRINS ;MAKE ANOTHER COPY OF NAME HRL PNT,A ;ITEM NUMBER. QPUSH (PNLST,PNT) ;SAVE FOR LATER. NOPNM: MOVE A,-1(P) ;TYPE BITS PUSHJ P,ITMTYP ;GET TYPE INDEX HRL A,(P) ;ALSO ITEM NUMBER QPUSH (ITMSTK) POP P,A ;RESTORE A POP P,BITS POP P,LPSA ;; #KW# DON'T ALLOW INTERNAL OR EXTERNAL ITEMS MOVE TBITS,$TBITS(LPSA) TLZE TBITS,EXTRNL!INTRNL ;ITEMS CAN'T BE INTERNAL OR EXTERNAL ERR ,1 MOVEM TBITS,$TBITS(LPSA) ;; #KW# MOVEM PNT2,$VAL2(LPSA) ;SAVE THE POINTER TO INTEGER!!!! POPJ P, ;EVEN IF "GOGOL", ITEMS DON'T NEED LOCATIONS IDLIS: TRNN TBITS,PROCED TLNE TBITS,SBSCRP JRST [TLZE TBITS,VALUE ERR ,1 TLO TBITS,REFRNC TRZ TBITS,INPROG ;ONLY RELEVANT TO PROCED JRST IDFXN] TLNN TBITS,REFRNC TLO TBITS,VALUE ;IMPLIED VALUE IDFXN: TRNE TBITS,PROCED TLO TBITS,ANYTYP MOVEM TBITS,$TBITS(PNT) ;;#HR# 6-14-72 JRL HANDLE STRING ITEMVAR FORMAL PARAMETERS TRNE TBITS,ITEM!ITMVAR ;IGNORE STRING BIT IF ITEM TRZ TBITS,STRING!DBLPRC ;;#HR# ;UPDATE THE STACK COUNTERS ACCORING TO TYPE OF PARAMETER MOVEI TEMP,1 TLNE TBITS,REFRNC JRST IDFXN1 TRNE TBITS,STRING JRST [AOS SPARNO POPJ P,] TRNE TBITS,DBLPRC TLO TEMP,1 ;VALUE LONG IDFXN1: ADDM TEMP,APARNO ;SOMETHING ON P STACK POPJ P, ^ENDDEC:PUSHJ P,ENDJMP ;FIX UP JUMP AROUND PROCS, IF ANY JFCL ;IGNORE SKIPPEDNESS SKIPN LPSA,GENLEF+1 ;DID WE DEFINE ANYTHING? POPJ P, ;NO -- RETURN HRRZ TEMP,PCNT ;UPDATE LOC OF FIRST WORD OF BLOCK HRLM TEMP,$VAL2(LPSA) ENDDE: TLZ FF,TOPLEV POPJ P, ;ALL DONE ^^ENDJMP: MOVE TEMP,TPROC ;SURROUNDING PROCEDURE SEMANTICS HLRZ TEMP,%TLINK(TEMP) ;2D PROC BLOCK MOVE B,$SBITS(TEMP) TRNN B,-1 ;DID ANYBODY JUMP? (SEE PRDEC) JRST CPOPJ1 ; NOBODY DID HLLZS $SBITS(TEMP) ;CLEAR FOR NEXT TIME HRL B,PCNT JRST FBOSWP ;NOW FIX UP JUMP AND QUIT ^CPOPJ1:AOS (P) ;THE CANONICAL SKIP-RETURN POPJ P, ;DONE ;HERE WHEN YOU SEE THE MATCHING "END" ^UP1: OPTSYM %.SCOD ;END OF START!CODE SKIPA PNT,GENLEF+1 ;FOR CODE!BEGIN SEQUENCES ^UP2: MOVE PNT,GENLEF+2 ;BEGIN SEMANTICS. UPPP: MOVEM PNT,GENRIG ;SAVE FOR NAME CHECKING. JUMPE PNT,NMSUB ;NO BLOCK ASSOCIATED WITH THIS BEGIN MOVE TEMP,PCNT HLRZ LPSA,%TLINK(PNT) ;LPSA=SECOND BLOCK SEMBLK ;;%DH% JFR 11-16-75 JUMPE LPSA,UPPP.1 ;JUMP IF NOT THERE HRLM TEMP,$VAL2(LPSA) ;STORE LAST WORD OF CODE HRRZ LPSA,(LPSA) ;SECOND SEMBLK OF ENCLOSING BLOCK ;;#XO# ! JFR 10-17-76 JUMPE LPSA,.+2 ;FOR FINAL END MOVEM LPSA,TRKBEG UPPP.1: ;;%DH% ^ JUMPL PNT,UPCHK ;THIS BLOCK HAS DECLARATIONS ... ;;#%%# BY JFR 11-8-74 FIX WHAT I DID YESTERDAY BAIL< SKIPE BAILON JRST .+3 ;YES. PRETEND IT HAS A NAME--WILL BE SUPPLIED BY BAISYM >;BAIL ;;#%%# ^ SKIPN $PNAME(PNT) ;NAMED COMPOUND STATEMENT? JRST NONM ; NO, FORGET IT HRRZS PNT ;LH 0 TO INDICATE PRESENCE OF NAME QPUSH (BLKIDX,PNT) ;PUT CPD STMT SEMBLK IN STACK SETZM %RVARB(PNT) ;MAKE SURE THERE'S NO LIST SOS NMLVL ;LOWER DDT LEVEL BY ONE CREFWQ: TLNN FF,CREFSW ;CREFFING ? POPJ P, ;DON'T DELETE THE BLOCK MOVEI LPSA,(PNT) ; POINTER TO BLOCK. JRST CREFBLOCK ;AND CREF BLOCK EXIT. NONM: MOVE LPSA,PNT PUSHJ P,URGSTR ;IN CASE IT WAS A NAMED BLOCK..!! FREBLK NMSUB: POPJ P, UPCHK: PUSHJ P,GOSTO ;STORE EVERYONE MOVE TBITS,$VAL(PNT) ;;#KT# ! TYPO AS TO WHERE KILL SET IS HRRZ C,$ACNO(PNT) ;IF WE HAVE A KILL LIST JUMPN C,DBEX ;MUST BEXIT LDB C,[POINT LLFLDL,$SBITS(PNT),35] ;PICK UP LEXIC LEVEL CAIE C,1 ; IF NOT GLOBAL AND NOREC < TDNN TBITS,[ XWD SBSCRP,SET] ;IF ONE OF THE BAD GUYS >;NOREC REC < TDNN TBITS,[ XWD SBSCRP,SET!PNTVAR] ;IF ONE OF THE BAD GUYS >;REC JRST EMJR ;THINGS ARENT SO EASY ;;#KX# 1-9-73 DO ALLSTO BEFORE YOU BEXIT -- RHT DBEX: PUSHJ P,ALLSTO ; HRR C,PCNT HLL C,$SBITS(PNT) HRLM C,$SBITS(PNT) ;FIXUP BK LVI REF EMIT XCALL EMJR: HRROS PNT ;ASSUME NO NAME SKIPE $PNAME(PNT) JRST [HRRZS PNT ;WRONG AGAIN SOS NMLVL ;NAME LEVEL PUSHJ P,CREFWQ ;POSSIBLY CREF BLOCK EXIT. JRST .+1] HLRZ A,$TBITS(PNT) ;BITS OF PROTECTED ACS COMMENT  HORRIBLE LOOP TO UNDO PROTECTION OF ACS IN THIS BLOCK  PUSH P,B PUSH P,D MOVEI D,11 ;;#RN# USED TO BE 1000 ;; MOVEI B,2000 ;BIT FOR AC 11 ;;#RW# SHOULD BE 1000, AFTER ALL (IE 1 LSH 9 = '1000) MOVEI B,1000 UPACHK: TDZE A,B ;DID WE PROTECT IT HRRZS ACKTAB(D) ;UNPROTECT IT LSH B,-1 SOJGE D,UPACHK ; POP P,D POP P,B ;************************************** REC < RCLPOP: QPOP(RCLPDL) ;GET A RECORD CLASS BLOCK JUMPE A,[ ERR ,1 JRST RPPPD ] CAMN A,[-1] ;THIS WAS THE SIGN JRST RPPPD ;ALL DONE HRRZ LPSA,A ;A SEMBLK FREBLK ;RETURN IT JRST RCLPOP ;& ASK FOR ANOTHER ONE RPPPD: >;REC QPUSH(BLKIDX,PNT) MOVE A,$ADR(PNT) HLRM A,TTOP ;RESTORE IT. HRRM A,VARB ;RESTORE THE VARB POINTER. SOS LEVEL JRST FREBUK ;come up a level in symbol buckets. ; Check for match on block names. ;;%CR% JFR 7-29-75 SUPPLY MORE INFO IF MISMATCH ^NAMCHK: MOVE PNT2,GENLEF ;END NAMED SKIPE PNT,GENLEF+1 ;BLOCK SEMANTICS. SKIPN A,$PNAME+1(PNT) ;B.P. FOR BEGIN JRST NMCHKK ;CAN'T MATCH BEGIN CAMN A,$PNAME+1(PNT2) ;AND THE OTHER POPJ P, JRST MTCERR ;NO GOOD NMCHKK: MOVE TEMP,TPROC ;TRY FOR MATCH WITH MOVE A,@$PNAME+1(TEMP) ;CURRENT PROC NAME CAMN A,@$PNAME+1(PNT2) ; (FIRST WORD MATCH ONLY) POPJ P, JUMPN PNT,.+2 ERR ,1,CPOPJ MTCERR: HLRZ TEMP,%TLINK(PNT) ;SECOND BLOCK SEMBLK ERRSPL 1,[[ASCIZ\ Names of BEGIN and END do not match. BEGIN @I @E/@D \] PWORD $PNAME+1(PNT) ;B.P. TO BEGIN NAME PWORD $PNAME+1(TEMP) ;LINE # OF BEGIN PWORD $PNAME(TEMP)] ;PAGE # POPJ P, ;;%CR% ^ SUBTTL EXECS for REQUIRE Verb DSCR RQ00, RQSET, SRCSWT PRO RQ00 RQSET SRCSWT REQERR DES These routines handle the REQUIRE Syntax of the forms: | | PNAMES | | SYSTEM!PDL | | STRING!PDL | n | STRING!SPACE | | ARRAY!PDL | | NEW!ITEMS | | VERSION REQUIRE |-----------------------| | | LIBRARY | | LOAD!MODULE | "file description" | SEGMENT!FILE | | SEGMENT!NAME | | SOURCE!FILE |-----------------------| | "2 or 4 characters" | DELIMITERS |-----------------------| | "some characters" | ERROR!MODES | | COMPILER!SWITCHES PNAMES and SOURCE!FILE are handled specially  ;; %AN% - ALL REQUIRE STUFF MODIFIED TO ALLOW CONSTANT EXPRESSIONS, ;; THIS CODE USED TO LOAD AC A FROM SCNVAL, AND THE INDIVIDUAL ROUTINES ;; DID WHAT THEY WISHED WITH IT. ^DEFZRO: ;DEFAULT OF ZERO IF NO CONSTANT EXPRESSION MOVEI A,0 PUSHJ P,CREINT MOVEM PNT,GENLEF+1 POPJ P, ^RQSET: SETZM BITS ;IN CASE UNARY WAS CALLED GETSEM (1) ;SEMANTICS OF CONSTANT XCT RQTAB(B) ;DO SOMETHING ZPOPJ: POPJ P, RECORD: TRNN TBITS,INTEGR ;BETTER BE INTEGER CONSTANT ERR ,1 MOVE A,$VAL(PNT) ;THE INTEGER VALUE ;;#TR# FIX THIS CODE ; HRRZ TEMP,SPCTBL ;THE SPACE RESERVATIN TABLE ; ADDI TEMP,1 ;ONE MORE WORD ; HRRM TEMP,SPCTBL ;HOPEFULLY ;;%BR% IFN 0,< HACK < CAIN TEMP,=18 ;OVERFLOW? ERR ,1 CAILE TEMP,=17 ;PREVIOUS OVERFLOW? POPJ P, ;YES HRL A,B ;THE INDEX INDICATES WHICH TLO A,STDSPC ; SPACE IS REQUESTED MOVEM A,SPCTBL+1(TEMP) ;INTO LOADER BLOCK FOR LATER OUTPUT POPJ P, >;HACK >;0 ;; OLD NOHACK HERE ; CAILE TEMP,=18 ; ADDI TEMP,1 ;FOR RELOC WORD ; CAIL TEMP,=35 ;TOO MANY?? ; ERR ,1,CPOPJ ; HRL A,B ;THE INDEX TO SAY WHICH ; TLO A,STDSPC ;THE OP CODE ; MOVEM A,SPCTBL+1(TEMP) ;ZNXSRE: SETZM SPCTBL+2(TEMP) ; CAIE TEMP,=18 ; POPJ P, ; AOS SPCTBL ; AOJA TEMP,ZNXSRE ;GO MAKE A ZERO ;;OLD NOHACK ^ ;;%BR% ^ AOS TEMP,SPCTBL ;BUMP WORD COUNT HRRZ TEMP,TEMP ;WORD CNT IS IN RHS CAILE TEMP,=18 ;NEED EXTRA OFFSET FOR RELOC BYTE? ADDI TEMP,1 ;YES CAIL TEMP,=35 ;TOO MANY?? JRST [ERR ,1 SOS SPCTBL POPJ P, ] HRL A,B ;THE INDEX TO SAY WHICH TLO A,STDSPC ;THE OP CODE MOVEM A,SPCTBL+1(TEMP) SETZM SPCTBL+2(TEMP) ;MAKE A ZERO FOR THE NEXT ONE CAIN TEMP,=18 ;IS THIS THE END OF FIRST GROUP? SETZM SPCTBL+3(TEMP) ;YES, ALSO HAVE A RELOC WORD TO ZERO POPJ P, ;;#TR# ^ RQTAB: JRST PNAM ;PNAMES JRST RECORD ;SYSTEM PDL JRST RECORD ;STRING PDL JRST RECORD ;STRING SPACE JFCL ;ARRAY PDL NO LONGER EXISTS JRST RNWITM ;NEW ITEMS JRST RVERNUM ;VERSION NUMBER JRST LBSET ;LIBRARY REQUEST JRST PRGSET ;LOAD MODULE REQUEST. JRST REQERR ;SOMETHING WRONG WITH SOURCE!FILE RQST JRST DELSTG ; PROCESS REQUIRE DELIMITERS COMMAND JRST REPDEL ; PROCESS REPPLACE DELIMITERS COMMAND JRST POPDEL ; PROCESS POP!DELIMITERS COMMAND JRST NULDEL ; PROCESS NULL!DELIMITERS COMMAND SETOM ALLGLO ; COMPILE FOR GLOBAL LEAP ONLY JRST SEGSET ;LOGICAL SEGMENT NAME REQUEST JRST SEGFL ;SEGMENT FILE NAME REQUEST JRST INMAIN ;GO INITIALIZE MAINPR JRST REQPLL ; POLLING INTERVAL JRST LPBUCK ; REQUIRE n BUCKETS JRST ITMSTRT ;ITEM START JRST MODSET ;ERROR MODES ;;%DB% ! JFR 9-21-75 JRST SWTMOD ;COMPILER!SWITCHES ;; \UR#7\ require overlap!ok \ur#6\ require verify!datum SETOM OKLPOV ;INHIBIT LEAP WARNING AT RUNTIME JRST VERHAND ; VERIFY!DATUM ;; \ur#7, ur#6\ RNWITM: TRNN TBITS,INTEGR ;INTEGER REQUIRED ERR ,1 MOVE A,$VAL(PNT) HRRM A,NWITM ;INTO SPACE ALLOCATION BLOCK POPJ P, RVERNUM: TRNN TBITS,INTEGR!FLOTNG ERR ,1 MOVE A,$VAL(PNT) MOVEM A,VERNO POPJ P, LBSET: SKIPA B,[LBTAB] ;LIBRARY OUTPUT BLOCK ADDR PRGSET: MOVEI B,PRGTAB ;PROGRAM OUTPUT BLOCK ADDR TRNN TBITS,STRING ;HAD BETTER BE STRING CONSTANT ERR ,1,ZPOPJ HRROI TEMP,$PNAME+1(PNT) POP TEMP,PNAME+1 POP TEMP,PNAME ;SET UP FOR CALL JRST PRGOUT ;OUTPUT REQUEST, RETURN SEGSET: GLOC < PUSHJ P,GETSOM ;GET NAME, SET UP TABLE POINTER MOVEM C,SEGNAM ;NAME ONLY, PUT IN SPACE BLOCK >;GLOC POPJ P, SEGFL: GLOC < PUSHJ P,GETSOM JUMPN A,.+2 ;DEVICE MOVSI A,() ;DEFAULT MOVEM A,SEGDEV ;DEVICE NAME MOVEM C,SEGFIL ;FILE NAME MOVEM D,SEGPPN ;WHEEE (TRANSLATION -- PPN) >;GLOC POPJ P, GLOC < GETSOM: ;PNT pnts to STRING REPRESENTING REQUEST TRNN TBITS,STRING ;HAD BETTER BE STRING CONSTANT ERR ,1,ZPOPJ HRROI TEMP,$PNAME+1(PNT) ;PNAME POP TEMP,PNAME+1 POP TEMP,PNAME JRST FILSCN ;CONVERT TO SIXBIT IN A,C,D >;GLOC DELSTG: ; SEMANTICS OF STRCON ALREADY SET UP TLNE TBITS,CNST ; CONSTANT? TRNN TBITS,STRING ; STRING? ERR ,1,CPOPJ ; ^GETDEL: HRRZ LPSA,$PNAME(PNT) ; GET STRING CHARACTER COUNT JUMPE LPSA,NULDEL ; NULL DELIMITER STRING? MOVE PNT,$PNAME+1(PNT) QPUSH (DELSTK,<(PNT)>) ; SAVE THE DELIMITERS GETDL1: SETOM REQDLM MOVE TEMP,[XWD -DELNUM,0] ; FOR AOBJN ^GETDL2:SOJGE LPSA,.+2 ; DELIMITER SCANNER LOOP ERR ; ILDB B,PNT ; GET NEXT DELIMITER SKIPG SCNTBL(B) ; SPECIAL OR IGNORABLE? JRST GETDL2 ; YES, GET NEXT SKIPN SWBODY ; SPECIAL DELIMITER DEFINITION? MOVEM B,LOCMBD(TEMP) ; NO, STORE FOR PERMANENT REFERENCE MOVEM B,CURMBG(TEMP) ; STORE FOR TEMPORARY REFERENCE AOBJN TEMP,GETDL2 ; CHECK IF DONE POPJ P, ; YES REPDEL: QPOP (DELSTK) JRST DELSTG POPDEL: QPOP (DELSTK) QLOOK(DELSTK) ; GET A POINTER TO TOP ELEMENT OF DELSTK SETZM REQDLM SKIPN (A) POPJ P, HRLI A,() MOVE PNT,A MOVEI LPSA,DELNUM JRST GETDL1 NULDEL: SETZM REQDLM QPUSH (DELSTK,REQDLM) POPJ P, ^MKNSTB: MOVEI C,1 ; INITIALIZE COUNT FOR NESTABLE CHARS. MOVEI A,NUMCHA ; NUMBER OF CHARACTERS CONCNV: SOJL A,CPOPJ ; DONE? MOVE B,SCNTBL(A) ; LOAD AND TEST IF NESTABLE CHARACTER TLNN B,NEST ; JRST CONCNV ; NO, GET NEXT CHAR MOVEM C,NSTABL(A) ; YES, NSTABL CONTAINS INDEX AMOUNT ; TO BE ADDED TO LOCNST TLNE B,LNEST ; DONE WITH A NESTED PAIR? ADDI C,1 ; YES, INCREMENT COUNTER JRST CONCNV ; GET NEXT COMMENT REQPLL -- SETS POLINT ^REQPLL: TLNE TBITS,CNST ;BETTER BE CONSTANT INTEGER TRNN TBITS,INTEGR ; ERR ,1,CPOPJ MOVE A,$VAL(PNT) ;GET VALUE MOVEM A,POLINT ; JUMPG A,INMAIN POPJ P, LPBUCK: ; FOR REQUIRE n BUCKETS TRNN TBITS,INTEGR ; BETTER BE INTEGER ERR ,1,CPOPJ JUMPGE A,.+2 MOVEI A,0 ; MAKE SURE IS POSITIVE JFFO A,.+2 ; FIND FIRST ONE JRST MINBKT ; MINIMUM NUMBER OF BUCKETS IS 2 HRLZI C,400000 ; A BIT FOR TESTING MOVN B,B LSH C,(B) ; C NOW IS THE LARGEST POWER OF TWO ; SUCH THAT C LEQ n CAME A,C ; SEE IF n WAS A POWER OF TWO LSH C,1 ; NO, GO TO NEXT HIGHER POWER. HAVSIZ: HRLM C,NWITM POPJ P, MINBKT: MOVEI C,2 JRST HAVSIZ ;; %AG% ITEM!START ^^ITMSTRT: MOVE TEMP,[XWD 11,10] ;SEE IF LEGAL CAME TEMP,ITEMNO ERR ,1 TRNN TBITS,INTEGR ;INTEGER REQUIRED ERR ,1 CAILE A,10 CAIL A,7777 ERR ,1 HRLI A,(A) SUBI A,1 ;SO FIRST WILL ALLOCATE MOVEM A,ITEMNO POPJ P, ;; %AG% ;; \ur#6\ require verify!datums VERHAND: SETOM CHEDAT ; VERIFY ALL DATUMS ; LATER WILL INSTALL A WAY OF TURNING THIS OFF POPJ P, ;; \ur#6\ MODSET: AOS %QUIET ;MAKE EVERY THING QUIET MOVEI B,[0] MOVEM B,..STR ;NULL MESSAGE SETZM ..LOCA AOS ..LOCA ;LOCATION IS 0 TRNN TBITS,STRING ERR ,1 SKIPN B,$PNAME(PNT) ;STRING LENGTH POPJ P, HRRZ B,B PUSH P,B ;SAVE SO DSPATC DOESN'T KILL MOVE PNT,$PNAME+1(PNT) ;THE STRING PUSH P,PNT ;SAVE! SAVE! SAVE! REGISTER PARANOIA REP..: SOSL -1(P) ;DECREMENT CHARACTER COUNT JRST UNNCDE ;DECODE CHAR SOSGE %QUIET ;RAN OUT OF STRING SO GO AWAY SETZM %QUIET ; IN CASE ANY SETZM %QUIETS IN DSPATCH SUB P,X22 ;FIX STACK POPJ P, UNNCDE: ILDB B,(P) ;FIRST LETTER PUSHJ P,DSPATC ;GO PRETEND THIS IS A REALLY ERROR CAIE B,"A" ;RETURNS HERE IF LETTER IS ACTIVATION LETTER JRST REP.. ;RETURNS HERE IF LETTER IS MODE OR UNKNOWN SETOM %ERGO JRST REP.. EXTERNAL OUTSTR ^TYPMSG: MOVE USER,GOGTAB; MOVE SP,SPDL(USER) GETSEM (1) TRNN TBITS,STRING ERR ,1,CPOPJ PUSH SP,$PNAME(PNT) PUSH SP,$PNAME+1(PNT) PUSHJ P,OUTSTR ;WRITE IT OUT JRST SCOMM1 ;ZAP STC BLOCK ^SRCSWT: ; FIRST CHECK VALIDITY OF SOURCE!FILE SWITCHING RQST, SET SPECIAL SWITCHER MOVE TBITS2,SCNWRD TLNE TBITS2,MACIN ;IF IN MACRO, ILLEGAL ERR ,1,SCANNER SETOM SRCDLY ;FLAG SCANNER POPJ P, ; NOW TRY THE SWITCH-OVER ; CHECK IF THE FILE WAS ACTUALLY SWITCHED ^SRCCHK: SKIPE SRCDLY ;WILL BE ZERO IF SWITCHED ERR ;;#YT# ! JFR 2-2-77 COUNT THAT LINE AOS BINLIN POPJ P, ^REQERR: ERR ,1 POPJ P, ;;%DB% JFR 9-21-75 SWTMOD: TLNE TBITS,CNST ; CONSTANT? TRNN TBITS,STRING ; STRING? ERR ,1,CPOPJ ; PUSH P,PNAME ;SAVE STATE INFO PUSH P,PNAME+1 NOTENX< PUSH P,TYICORE SETOM TYICORE ;GET FROM PNAME PUSH P,TTYTYI SETZM TTYTYI ;AND NOT FROM HERE PUSH P,EOL PUSH P,EOF >;NOTENX MOVE TEMP,$PNAME(PNT) ;TRANSFER STRING HRRZM TEMP,PNAME ;COUNT ONLY MOVE TEMP,$PNAME+1(PNT) MOVEM TEMP,PNAME+1 ;;#XN# JFR 9-18-76 JSP PNT,SWTGET ;PROCESS SWITCH SKIPLE PNAME ;ANY CHARS LEFT? JRST [TLZ FF,FFTEMP ;YES. SET SIGN TO PLUS SETZB C,D ;ZERO THE NUMBERS JRST SWGPAR] ;AGAIN, INTO THE MIDDLE! ;;#XN# ^ NOTENX< POP P,EOF ;RESTORE STATE POP P,EOL POP P,TTYTYI POP P,TYICORE >;NOTENX POP P,PNAME+1 POP P,PNAME POPJ P, ;;%DB% ^ SUBTTL EXECS for MACRO (DEFINE) Declarations DSCR DFPREP, DCPREP, DWPREP, DFPINS, DFSET, DFENT, MACOFF, MACON PRO DFPREP DCPREP, DWPREP, DFPINS DFSET DFENT MACOFF, MACON DES Execs for syntax DEFINE macnam(a1,a2..)="macro body", macnam2=....,...; Relies heavily on mechanisms built into the SCANNER to parse the macro body, insert parameters. SEE SCANNER  Comment * DFR: @I ( drarrow DPL EXEC DFPR1 SCAN 2 GO TO DPA @I SG drarrow DPL SG EXEC DFPREP GO TO LEQ OR GO TO Q0 DFPREP -- prepare to define a macro body. Enter DEFINE symbol. Use current def if it's at the same level (done in ENTER). Get a new symbol table bucket. DCPREP -- prepare to define a conditional compilation CASEC body. Check if first casec and if not then enter the computed casec value in the $VAL2 entry of the semblk obtained for the casec body. DWPREP -- prepare to define a conditional compilation WHILEC, FORC, or FORLC body. * ^MACON: TLZ FF,NOMACR ; TURN MACRO EXPANSION ON POPJ P, ; RETURN ^EVMCOF: SKIPN EVLDEF ; TURN OFF MACRO EXPANSION ONLY IF ; EVALDEFINE IS NOT IN PROGRESS ^MACOFF: TLO FF,NOMACR ;NO MACRO EXPANSIONS WHEN REDEFINING! POPJ P, ^DCPREP: GETBLK NEWSYM ; SEMBLK FOR CASEC BODY GETSEM (1) ; SEMANTICS OF CASEC NUMBER MOVE TEMP,$VAL(PNT) ; GET CASEC NUMBER JUMPN TEMP,NOFRST ; TWIDDLE IF NOT FIRST CASEC PUSHJ P,CPSHEN ; SET ENDC DOESN'T TRIGGER A PARSER SWITCH FLAG SETOM SWCPRS ; PARSER SWITCHING IS OK (I.E. IFC IN BODY OF CASEC ; TO BE EXECUTED) JRST CMPRP2 ; DON'T TWIDDLE SINCE FIRST CASEC NOFRST: MOVEM TEMP,$VAL2(LPSA) ; STORE CASEC NUMBER IN $VAL2 OF THE SEMBLK MOVEM LPSA,GENRIG+1 ; SAVE SEMANTICS OF PSEUDO MACRO BODY SEMBLK MOVE TEMP,%CFLS1 ; TWIDDLE MOVEM TEMP,PARRIG ; NOT THE FIRST CASEC JRST DWPRP1 ; REST OF MACRO BODY PRELIMINARIES ^DWPREP: GETBLK NEWSYM ; SEMBLK FOR WHILEC, FORC, OR FORLC BODY DWPRP1: HRLZI TEMP,DEFINE ; GET GOOD BITS MOVEM TEMP,$TBITS(LPSA) ; SET SEMBLK DESCRIPTOR HRRZS %TLINK(LPSA) ; ZERO THE MACRO BODY DEFINITION LINK JRST CMPRP2 ; REST OF MACRO BODY PRELIMINARIES ^DFPREP: HRLZI TEMP,DEFINE ; GET GOOD BITS MOVEM TEMP,BITS ; PREPARE TO DO AN ENTERS PUSHJ P,ENTERS ; ENTER MACRO NAME IF NOT ALREADY DEFINED MOVE LPSA,VARB ; CHECK IF DEFINE IS HAPPENING BEFORE THE SKIPN LEVEL ; OUTER LEVEL BLOCK HAS BEEN STARTED. IF MOVEI LPSA,RESYM ; YES, THEN SET VARB TO RESYM SO DONES WILL MOVEM LPSA,VARB ; WORK PROPERLY. CMPRP2: PUSHJ P,MAKBUK ;DOWN ONE LEVEL FOR PARAMETERS AOS LEVEL MOVE LPSA,NEWSYM ;SYMANTICS OF ENTRY MOVEM LPSA,GENRIG ;MAY BE GARBAGING "="'S SEMANTICS MOVE TEMP,VARB ;SAVE VARB LIST -- WILL LINK FORMALS MOVEM TEMP,$ADR(LPSA) ; OLD VARB POINTER IS SAVED IN $ADR SO THAT ; THE MACRO BODY IS STILL KNOWN SETZM VARB HLLZS $VAL(LPSA) ;CLEAR #PARAMS COUNT (SAVE COUNT FOR PREV DEF). SETZM $ACNO(LPSA) ;WILL POINT AT FIRST PARAM TLZ FF,NOMACR ;MACROS EXPANDED AGAIN POPJ P, Comment  DPA: SG @I , drarrow SG EXEC DFPINS SCAN 2 DPA SG @I ) drarrow SG EXEC DFPINS SCAN LEQ #Q0 Insert macro parameter: 1. Enter the symbol 2. Insert in list off %TLINK in macro name semantics  ^MDFPNS: TLZ FF,NOMACR ; MACROS EXPANDED AGAIN WHEN THROUGH SCANNING ; FORMALS ^DFPINS: HRLZI TEMP,FORMAL!DEFINE ;ENTER PARAM (LINK ON SPECIAL VARB RING) MOVEM TEMP,BITS PUSHJ P,ENTERS MOVE TEMP,GENLEF+2 ;SEMANTICS FOR MACRO NAME AOS A,$VAL(TEMP) ;COUNT MACRO PARAMS MOVE LPSA,NEWSYM ;SEMANTICS OF THIS PARAM SKIPN $ACNO(TEMP) ;IS THIS THE FIRST ONE? MOVEM LPSA,$ACNO(TEMP) ; YES, STORE POINTER TO FIRST HRRZM A,$VAL(LPSA) ;STORE PARAM NUMBER POPJ P, Comment  LEQ: STC drarrow EXEC SPDMBD SCAN LEQ1 Check if a special macro body delimiter declaration has occurred  ^SPDMBD: SKIPN REQDLM ; TRYING TO OVERRIDE NULL DELIMITER MODE? SETOM RSTDLM ; YES, SET FLAGS SO CAN RESET PROPERLY WHEN DONE SETOM REQDLM ; SETOM SWBODY ; SET SWITCH DELIMITER DECLARATION FLAG MOVE TEMP,[XWD -2,0] ; SET UP A COUNT MOVE PNT,GENLEF ; GET SEMBLK ADDRESS OF STRING HRRZ LPSA,$PNAME(PNT) ; GET READY FOR A SPECIAL DELIMITER MODE MOVE PNT,$PNAME+1(PNT) ; SCAN JRST GETDL2 ; GET SPECIAL DELIMITERS Comment  LEQ1: = drarrow EXEC DFSET SCAN 2 DEQ #Q0 Get ready for macro body  ^DFSET: JRST FFPUSH ; SAVE DEFLUK BIT OF FF AND TURN IT ON IN FF Comment  DEQ: DPL ICN , drarrow EXEC DFINE SCAN 2 DFR DDEF DPL ICN ; drarrow EXEC DFINE SCAN DS0 SDEF DPL ICN ; drarrow EXEC DFINE SCAN S1 #Q0 Eradicate formal parameter ring, turn off special string mode bit after macro scan -- install the macro body.  ^DFENT1: MOVE A,GENLEF+3 ; SEMBLK OF CASEC ENTRY JRST NOREDF ; NO PARAMETER LIST TO DELETE ^DFENT: MOVE A,GENLEF+2 ; GET SEMBLK ADDRESS MOVE LPSA,$ACNO(A) ; FORMAL LIST PUSHJ P,KILLST ; DELETE FORMAL PARAM LIST SETZM $ACNO(A) ; NO MORE LIST HRRZ TEMP,$VAL(A) ; #PARAMS FOR THIS (NEW) DEFINITION HRLZM TEMP,$VAL(A) ; #PARAMS FOR CURRENTLY ACTIVE DEF. HLRZ LPSA,%TLINK(A) ; CHECK IF THE MACRO HAS BEEN PREVIOUSLY JUMPE LPSA,NOREDF ; DEFINED, AND IF YES DELETE THE PREVIOUS PUSHJ P,REMOPL ; DEFINITION IF IT IS THE ONLY REFERENCE TO IT NOREDF: MOVE TEMP,$ADR(A) ; RESTORE SAVED VARB POINTER MOVEM TEMP,VARB ; (IT WAS USED TO KEEP FORMALS LOCATED) MOVE LPSA,GENLEF+1 ; MACRO BODY (STRING CONST) SEMANTICS MOVE TBITS,$TBITS(LPSA) ; GET GOOD BITS TRNE TBITS,STRING ; TEST IF A STRING AND SET IT TO STRING JRST NOCNST ; YES, NO NEED TO CONVERT CONSTANT TO STRING PUSH P,$VAL(LPSA) ; PUSH VALUE PUSHJ P,REMOPL ; DELETE SEMBLK OF NUMERIC CONSTANT IF POSSIBLE EXCH SP,STPSAV ; GET STRING POINTER MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE ;;#ZJ# 78-Jun-24 KS/DON BUGFIX TO PREVENT MACRO FROM EXPANDING AS LONG INTEGER SKIPL (P) ; TEST FOR NEGATIVE INFINITY JRST .+4 ; (BOMBS ON RE-EXPANSION IF STORED AS DECIMAL) SOSL (P) JRST [AOS (P) ; IS NEGATIVE INFINITY--USE OCTAL EXPANSION PUSH SP,[XWD 0,1] ; LENGTH OF STRING (PREFIXED ') PUSH SP,[POINT 7,[ASCIZ/'/]] PUSHJ P,CVOS ; CONVERT TO OCTAL STRING PUSHJ P,CAT ; CONCATENATE STRING AFTER ' JRST .+3] ; JOIN UP WITH DECIMAL ROUTE AOS (P) ;;#ZJ# 78-Jun-24 KS/DON END BUGFIX PUSHJ P,CVS ; CONVERT TO STRING POP SP,PNAME+1 ; FIRST WORD OF STRING DESCRIPTOR POP SP,PNAME ; SECOND WORD OF STRING DESCRIPTOR EXCH SP,STPSAV ; RETURN STRING POINTER MOVSS POVTAB+6 ; KEEP ERROR MESSAGES IN SYNCH PUSHJ P,STRINS ; MAKE STRING CONSTANT MOVEM PNT,GENLEF+1 ; RECORD RESULTS WHERE WILL BE SEEN NOCNST: SOS LEVEL PUSHJ P,FREBUK ;RETURN UP JRST CLRSET ;CLEAR BITS ^SWDLM: SKIPN SWBODY ; NEED TO SWAP MACRO BODY DELIMITERS? POPJ P, ; NO, RETURN SETZM SWBODY ; RESET SWITCH DELIMITER DECLARATION FLAG SKIPN RSTDLM ; RESTORING NULL DELIMITERS MODE? JRST .+4 ; NO SETZM RSTDLM ; RESTORE THE APPROPRIATE FLAGS SETZM REQDLM ; POPJ P, ; HRROI TEMP,LOCMBD+1 ; GET RESTORING ADDRESS POP TEMP,CURMED ; RESTORE START DELIMITER POP TEMP,CURMBG ; RESTORE END DELIMITER POPJ P, ; RETURN ^SETDLM: QPUSH(LOKDLM,DLMSTG) ; SAVE CURRENT DLMSTG VALUE SKIPE REQDLM ; SPECIAL DELIMITER MODE? SETOM DLMSTG ; YES, POSSIBLY LOOKING FOR DELIMITED STRING POPJ P, ; RETURN ^OFFDLM: QPOP(LOKDLM,DLMSTG) ; CEASE LOOKING FOR DELIMITED STRING POPJ P, ; RETURN ^ENDMAC: MOVE LPSA,GENLEF+1 ; GET MACRO BODY SEMBLK EXCH SP,STPSAV ; GET STRING STACK POINTER MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS ; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED PUSH SP,[XWD 0,2] ; LENGTH OF FOLLOWING STRING PUSH SP,[POINT 7,[BYTE (7) 177 0]] ; END OF MACRO STRING PUSHJ P,CAT ; CONCATENATE POP SP,PNAME+1 ; SECOND WORD OF STRING DESCRIPTOR POP SP,PNAME ; FIRST WORD OF STRING DESCRIPTOR PUSHJ P,STRINS ; ENTER MACRO BODY STRING IN SYMBOL TABLE MOVE LPSA,GENLEF+2 ; LINK MACRO NAME TO MACRO BODY HRLM PNT,%TLINK(LPSA) ; EXCH SP,STPSAV ; RETURN STRING POINTER MOVSS POVTAB+6 ; KEEP ERROR MESSAGES IN SYNCH POPJ P, ; RETURN ^SWPON: SETOM SWCPRS ; SWITCHING PARSERS IS ALLOWED POPJ P, ; RETURN DSCR STCAT PRO STCAT DES Converts a macro body to a string. CVMS(macname). If called with a macro name and a parameter list, then the parameters are ignored and a suitable error message is emitted.  ^STCAT: TLZ FF,NOMACR ; TURN MACRO EXPANSION BACK ON ;;#OS# 10-31-73 HJS CHECK FOR UNDECLARED MACRO NAME SKIPE LPSA,GENLEF ; IS THIS A DECLARED MACRO? JRST CVMSOK ; YES, ERR ; NO, RETURN A NULL STRING SETZM PNAME ; SETZM PNAME+1 ; JRST UNDCVM ; CVMSOK: HLRZ LPSA,%TLINK(LPSA) ; CONVERT TO STRING AND ENTER IT IN THE ; SYMBOL TABLE IF NOT ALREADY THERE. RM1770: ;; #TA# (1 OF 2) DETECT WHEN LENGTH GOES NEGATIVE HRRZ TEMP,$PNAME(LPSA) ; SUBI TEMP,2 ; THE ONLY DIFFERENCE BETWEEN THE JUMPGE TEMP,.+2 ERR ,1 HRRM TEMP,PNAME ; STRING AND THE MACRO BODY IS ;; #TA# MOVE TEMP,$PNAME+1(LPSA) ; THAT THE STRING DOES NOT HAVE MOVEM TEMP,PNAME+1 ; 177-0 AT ITS END. UNDCVM: PUSH P,BITS ; PUSHJ P,STRINS ; POP P,BITS ; MOVEM PNT,GENRIG ; SET THE SEMANTIC STACK ENTRY TO ; THE SEMBLK ADDRESS OF THE STRING. POPJ P, ; DSCR CVPFRM, ASGOFF PRO CVPFRM, ASGOFF DES These routines are used to implement the CVPS construct which converts a macro actual parameter to a string. CVPS(formal parameter name). CVPFRM This routine fetches the appropriate parameter from the VARB ring associated with the cureent invocation of the macro and strips off the 177-0 at its end and converts it to a string. ASGOFF This routine turns off the flag which inhibits the expansion of macro actual parameters in case an error has occurred.  ^CVPFRM: SETZM ASGFLG ; TURN OFF ACTUAL MACRO PARAMETER EXPANSION MOVE B,GENLEF ; INHIBITION FLAG AND GET SEMBLK OF ACTUAL MOVE LPSA,DEFRNG ; PARAMETER TO BE CONVERTED TO A STRING GETITP: SOJE B,RM1770 ; RIGHT ,%RVARB, ; JRST GETITP ; ^ASGOFF: SETZM ASGFLG ; TURN OFF ACTUAL MACRO PARAMETER EXPANSION POPJ P, ; INHIBITION FLAG DSCR SPRZER, XOWST1, VALST1, HELAR3, HELST1, TYPST1, RSTST1, MKINT PRO SPRZER, XOWST1, VALST1, HELAR3, HELST1, TYPST1, RSTST1, MKINT DES These routines are used to process the CHECK!TYPE command which takes as an argument a declaration and forms a word containing the apporopriate bits in SPRBTS. SPRZER Zeroes SPRBTS. XOWST1 Gets bits corresponding to @XO. VALST1 Gets bits corresponding to @VAL. HELAR3 Gets the LPARRAY bit. HELST1 Gets the ITEM or ITEMVAR bits. TYPST1 Gets the @ALGLP bit. RSTST1 Gets the remaining bits (i.e. PROCED, RES, BILTIN, DEFINE, SBSCRP, and LPARRAY for a LPARRAY declaration. MKINT Creates an integer out of the SPRBTS value and places it on the stack.  ^SPRZER: SETZM SPRBTS ; SETOM NODFSW ; NO DEFINE TRIGGERING WHILE IN CHECK!TYPE. POPJ P, ; ^XOWST1: SKIPA A,XOTAB(B) ; ^VALST1: MOVE A,VALTAB(B) ; JRST ENDFRM ; ^HELAR3: MOVEI A,LPARRAY ; IORM A,SPRBTS ; ^HELST1: ^TYPST1: SKIPA A,TYPTAB(B) ; ^RSTST1: MOVE A,CHKTAB(B) ; ENDFRM: IORM A,SPRBTS ; POPJ P, ; ^MKINT: SETZM NODFSW ; ALLOW DEFINE TRIGGERING TO HAPPEN AGAIN. MOVE A,SPRBTS ; JRST MKINT2 ; MAKE AN INTEGER AND PLACE IT ON THE STACK. DSCR FFPUSH, FFPOP PRO FFPUSH, FFPOP DES These rotines are used to save and restore the DEFLUK bit of FF on a QSTACK pointed to by DEFDLM. This is necessary due to compile-time variables whose definition may cause other macros to be called. DEFLUK is used to indicate that a macro body is about to be scanned or a set of actual parameters to a macro are about to be scanned. FFPUSH Saves the DEFLUK bit of FF on a QSTACK pointed to by DEFDLM (actually save the entire value of FF). FFPOP Restores the DEFLUK bit of FF from the QSTACK pointed to by DEFDLM.  ^FFPUSH: MOVEI LPSA,DEFDLM ; GET QSTACK POINTER MOVE A,FF ; A CONTAINS ITEM TO BE PUSHED IN QSTACK TLO FF,DEFLUK ; TURN ON DEFLUK BIT IN FF JRST BPUSH ; PUSH IN QSTACK ^FFPOP: MOVEI LPSA,DEFDLM ; GET STACK POINTER PUSHJ P,BPOP ; POP TOP OF QSTACK INTO A TLZ FF,DEFLUK ; RESTORE DEFLUK BIT OF FF TO PREVIOUS VALUE TLNE A,DEFLUK ; TLO FF,DEFLUK ; POPJ P, ; DSCR DLMPSH, DLMPOP PRO DLMPSH, DLMPOP DES These routines are used to save and restore the DEFLUK bit of FF and the value of the DLMSTG flag after encountering the DEFINE reserved word and after encountering the = sign in a macro definition. This is necessary so that macro names will be properly entered in the symbol table. DLMPSH Saves the current value of DLMSTG and sets it to zero. Also saves the current value of the DEFLUK bit of FF and sets it to zero. DLMPOP Restores the value of DLMSTG from the stack. Also restores the DEFLUK bit of FF.  ^DLMPSH: QPUSH(LOKDLM,DLMSTG) ; SAVE DLMSTG SETZM DLMSTG ; DON'T LOOK FOR DELIMITED STRINGS MOVEI LPSA,DEFDLM ; GET STACK POINTER MOVE A,FF ; TLZ FF,DEFLUK ; STRINGS SCANNED IN NON-MACRO MODE JRST BPUSH ; PUSH IN QSTACK ^DLMPOP: QPOP(LOKDLM,DLMSTG) ; RESTORE DLMSTG JRST FFPOP ; RESTORE DEFLUK DSCR CPSHBT, CPOPBT, DPSHBT, DPOPBT PRO CPSHBT, CPOPBT, DPSHBT, DPOPBT DES These routines are used to save and restore bits before and after conditional compilation and macro definitions. This enables declarations to be interrupted without having the partially accumulated BITS value destroyed when expressions are looked up or string constants created. CPSHBT Saves current BITS value during conditional compilation. CPOPBT Restores the value of BITS after conditional compilation. DPSHBT Saves current BITS value during a macro definition. DPOPBT Restores the value of BITS after a macro definition.  ;;#YF# JFR 1-8-77 handle QRCTYP. could be in middle of RECORD!POINTER declaration ^CPSHBT:SKIPA LPSA,[CBTSTK] ^DPSHBT:MOVEI LPSA,DBTSTK MOVE A,BITS PUSHJ P,BPUSH ;QPUSH(stack,BITS) SETZM BITS MOVE A,QRCTYP JRST BPUSH ;QPUSH(stack,QRCTYP) ^CPOPBT:SKIPA LPSA,[CBTSTK] ^DPOPBT:MOVEI LPSA,DBTSTK PUSHJ P,BPOP MOVEM A,QRCTYP ;QPOP(stack,QRCTYP) PUSHJ P,BPOP MOVEM A,BITS ;QPOP(stack,BITS) POPJ P, ;;#YF# ^ DSCR CPSHEN, CPSHEY, CPOPET PRO CPSHEN, CPSHEY, CPOPET DES These routines are used to allow parser switching in the bodies of WHILEC, CASEC, FORC, and FORLC statements. This enables one to conditionally compile these bodies. The routines serve to set and reset a flag which is kept in a QSTACK pointed at by ENDCTR. This flag indicates whether parser switching should occur when an ENDC is seen (i.e. if it is terminating a WHILEC, CASEC, FORC, or FORLC body, then no triggering should occur). CPSHEN Pushes a -1 on the QSTACK indicating that an ENDC seen with this value on top of the QSTACK is not to serve as a parser switching trigger. CPSHEY Pushes a zero on the QSTACK indicating that an ENDC seen with this value on the top of the QSTACK is to serve as a parser switching trigger. CPOPET Pops the QSTACK pointed to by ENDCTR when one is done with a particular ENDC parser switching trigger mode.  ^CPSHEY: TDZA A,A ; ^CPSHEN: SETOM A ; QPUSH(ENDCTR) ; POPJ P, ; ^CPOPET: QPOP(ENDCTR) ; POPJ P, ; DSCR DCLNT1,DCLNT2 PRO DCLNT1,DCLNT2 DES These routines are used for the DECLARATION and EXPR!TYPE commands. DCLNT1 Same as DCLNT2 for EXPR!TYPE. DCLNT2 This routine is used to process a DECLARATION(varname) command which looks up the varname in the symbol table and returns an integer having the value of the $TBITS entry in the symbol table. If the variable has not been declared, then a zero is returned. Note that macro names are not expanded here. Also, turn off the OWN bit if LPARRAY or SBSCRP are on and TOPLEV &[XWD EXTRNL,GLOBL].  ^DCLNT1: SKIPA A,GENLEF+1 ; GET SEMBLK FOR EXPR!TYPE ^DCLNT2: SKIPE A,GENLEF ; GET $TBITS VALUE IF DECLARED - ZERO MOVE A,$TBITS(A) ; OTHERWISE. TLNN A,SBSCRP ; TURN OFF OWN BIT IF LPARRAY OR SBSCRP AND TRNE A,LPARRAY ; TOPLEV &[XWD EXTRNL,GLOBL]. TLNN FF,TOPLEV ; JRST MKINT1 ; TDNN A,[XWD EXTRNL,GLOBL] ; TLZ A,OWN ; MKINT1: TLZ FF,NOMACR ; TURN MACRO EXPANSION BACK ON IF OFF MKINT2: PUSHJ P,CREINT ; CREATE INTEGER CONSTANT SEMBLK MOVEM PNT,GENRIG ; SET THE SEMANTIC STACK ENTRY TO ; THE SEMBLK ADDRESS OF THE NUMBER. POPJ P, ; ;;%DS% JFR 8-21-76 ^DCLNT3:MOVSI A,RES ;TBITS OF A RESERVED WORD MOVEI B,(B) ;ISOLATE INDEX IN RIGHT HALF CAIE B,-41 ;TRUE CAIN B,-40 ;FALSE IORI A,INTEGR CAIN B,-42 ;NULL IORI A,STRING CAIN B,145 ;NIL IORI A,LSTBIT!SET CAIN B,120 ;PHI IORI A,0+SET CAIN B,140 ;NULL!RECORD IORI A,PNTVAR ;; \ur#14 \ following used to be jrst mkint2. ;; LEFT NOMACRO EXPANSION ON. JRST MKINT1 ;AND AWAY WE GO DSCR DCLBEG,DCLEND PRO DCLBEG,DCLEND DES These routines are used to process EXPR!TYPE command which takes an arbitrary expression as an argument and returns an integer having the value of the $TBITS entry in the symbol table for the appropriate type. The difference between it and the DECLARATION command is that the latter does not expand macro names thus enabling the user to determine if variables have been used as macro names. Also, identifiers must have been previously declared if used here. DCLBEG Saves contents of accumulators and $SBITS values of their contents to enable recovery from damage done by code generators. Also turn off code generation, and save ADEPTH, PCNT, and SDEPTH. DCLEND Restore contents of accumulators and $SBITS values of their contents. Also restore PCNT and SDEPTH, and make sure ADEPTH has not changed.  ;;#SN# (5 OF 8) 5-30-74 RLS ALLOW RECURSIVE EXPR!TYPE ZERODATA EXPCNT: 0 ENDDATA ;;#SN# ^DCLBEG: TLNN FF,LPPROG PUSHJ P,OKSTAC MOVE A,[XWD ACKTAB,ACKSAV] ; SAVE ACKTAB IN ACKSAV BLT A,ACKSAV+12 ; MOVEI D,12 ; LPAT: MOVE PNT,ACKTAB(D) ; SAVE $SBITS IN SBSAV MOVE SBITS,$SBITS(PNT) ; MOVEM SBITS,SBSAV(D) ; SOJGE D,LPAT ; ;;#SN# (6 OF 8) 1-1-75 RLS ALLOW RECURSIVE EXPR!TYPE MOVE TEMP,EXPSPT AOS EXPCNT ;KEEP TRACK OF LEVELS IN RECURSION SETOM NOEMIT PUSH TEMP,ADEPTH PUSH TEMP,PCNT PUSH TEMP,SDEPTH ;;#VW# (1 OF 2) 12-6-75 RLS ANOTHER EXPR!TYPE PROBLEM PUSH TEMP,TTEMP ;ANOTHER GUY TO SAVE HRLI D,ACKSAV HRRI D,1(TEMP) BLT D,25(TEMP) ADD TEMP,[XWD 25,25] TLNN TEMP,400000 ERR MOVEM TEMP,EXPSPT ;;#SN# POPJ P, ^DCLEND: ;;#SN# (7 OF 8) 5-30-74 RLS ALLOW RECURSIVE CALLS TO EXPR!TYPE MOVE TEMP,EXPSPT HRLI D,-24(TEMP) HRRI D,ACKSAV BLT 4,ACKSAV+24 SUB TEMP,[XWD 25,25] MOVEM TEMP,EXPSPT ;;#SN# ;[clh] from 0 to 12 instead of 12 to 0. This is because of LONG REAL's, ;[clh] because their $ACNO entry points to the first AC. Thus the CLEAR ;[clh] and REMOP trigger correctly the first time we see them. ;[clh] MOVEI D,12 ; MOVSI D,-13 ; AOBJN POINTER FOR 0 TO 12 BEGLP: MOVE PNT,ACKTAB(D) ; CAMN PNT,ACKSAV(D) ; IF ACKTAB IS SAME AS ACKSAV, THEN JUST JRST AFTRM2 ; RESTORE $SBITS HRRZ C,$ACNO(PNT) ; CHECK IF AC HAS ALREADY BEEN REMOPED AND CAIE C,(D) ; IS THUS VALID JRST AFTREM ; YES PUSHJ P,CLEAR ; PUSHJ P,REMOP ; AFTREM: MOVE PNT,ACKSAV(D) ; RESTORE ACKTAB, $SBITS, AND $ACNO MOVEM PNT,ACKTAB(D) ; AFTRM2: MOVE SBITS,SBSAV(D) ; MOVEM SBITS,$SBITS(PNT) ; HRRM D,$ACNO(PNT) ; ENDLP: AOBJN D,BEGLP ;[clh] ;[clh] SOJGE D,BEGLP ; ;;#SN# (8 OF 8) RLS MAKE EXPR!TYPE RECURSIVE MOVE TEMP,EXPSPT ;;#VW# (2 OF 2) RLS ANOTHER EXPR!TYPE PROBLEM POP TEMP,TTEMP POP TEMP,SDEPTH POP TEMP,PCNT EXCH D,(TEMP) CAME D,ADEPTH ; EXPR!TYPE THEN ERROR SINCE PARAMETER ERR ; STACK WILL BE OUT OF SYNCH EXCH D,(TEMP) POP TEMP,ADEPTH MOVEM TEMP,EXPSPT ;POPPED STACK POINTER SOSG EXPCNT ;ONE LEVEL OUT -- DO WE START EMITTING? SETZM NOEMIT ;YES ;;#SN# POPJ P, ; DSCR CNDRCY, CNDRCN, CNDRCP PRO CNDRCY, CNDRCN, CNDRCP DES These routines are used to keep track of whether macros should be expanded in the false part of conditional compilation. IFCREC is used to denote the current mode and RECSTK points to the top of the qstack used to store the currently overridden values of IFCREC CNDRCY This routine is used to save the current IFC mode and set it to no expansion of macros in the false part of conditional compilation, CNDRCN This routine is used to save the current IFC mode and set it to expand macros in the false part of conditional compilation. CNDRCP This routine is used to restore the previous IFC mode.  ^CNDRCY: QPUSH(RECSTK,IFCREC) ; SETOM IFCREC ; POPJ P, ; ^CNDRCN: QPUSH(RECSTK,IFCREC) ; SETZM IFCREC ; POPJ P, ; ^CNDRCP: QPOP(RECSTK,IFCREC) ; POPJ P, ; DSCR PSHLST, POPLST DES PSHLST, POPLST DES These routines are used to indicate whether one is in the false part of conditional compilation or in the conditional compilation parser. This information is used by the SCANNER so that listing files can hopefully reflect the true program that is being compiled. The basic action of the SCANNER is to test the CNDLST flag when it is about to stack a result on the parse stack and if one is in the conditional compilation parser, then the listing buffer pointer is reset to the value it had prior to scanning the parse token in question. PSHLST This routine is used to indicate that listing should not be happening now. POPLST This routine is used to indicate that one is to revert to the previous mode of listing output.  ^PSHLST: QPUSH(LSTSTK,CNDLST) ; SAVE PREVIOUS COND. COMP. LISTING STATE SETOM CNDLST ; CEASE LISTING POPJ P, ; ^POPLST: QPOP(LSTSTK,CNDLST) ; RESTORE PREVIOUS COND. COMP. LISTING STATE POPJ P, ; ;; \ur#5\ ignore macro modies when kounting DSCR KLSTOF, KLSTON DES THESE ROUTINES ARE USED WITH KOUNTERS TO SUPPRESS THE INCLUSION OF MACRO DEFINITIONS WITHIN THE LISTING FILES. THIS IS NEEDED BECAUSE PROFIL CANNOT HANDLE MACRO DEFINITIONS USING DELIMITERS;  ^KLSTOF: ; TURN OFF LISTING IF /K SKIPN KOUNT ;ARE WE COUNTING? POPJ P, ;NO. NOTHING TO WORRY ABOUT QPUSH (LSTSTK,CNDLST) ;SAVE PREV STATE SETOM CNDLST ;CEASE LISTING POPJ P, ;;#YO# JFR 1-28-77 ^KLSTOC:SKIPA B,[","] ^KLSTON:MOVEI B,";" ; UNDO THE KLSTOF SKIPN KOUNT POPJ P, QPOP (LSTSTK,CNDLST) ;; HERE MAY HAVE TO FORCE A SEMI-COLON OUT TO THE LISTING FILE; MOVE TBITS2,SCNWRD TRNN TBITS2,NOLIST IDPB B,LPNT POPJ P, ;; \ur#5\ DSCR SETRDF, SETEDF, DEFOFF PRO SETRDF, SETEDF, DEFOFF DES These routines are used indicate when a REDEFINE or an EVALDEFINE are in progress. SETRDF This routine turns on the REDEFN flag which indicates that a REDEFINE of a macro is in progress. SETEDF This routine turns on the EVLDEF flag which indicates that an EVALDEFINE is in progress and thus the following macro name is expanded. DEFOFF This routine turns off the REDEFN and EVLDEF flags.  ^SETRDF: SETOM REDEFN ; POPJ P, ; ^SETEDF: SETOM EVLDEF ; POPJ P, ; ^DEFOFF: SETZM REDEFN ; SETZM EVLDEF ; POPJ P, ; DSCR INTSCN, ASGENT PRO INTSCN, ASGENT DES These routines are used to implement the ASSIGNC construct which allows assignment to macro formals. INTSCN This routine turns on the ASGFLG flag which indicates that the next internal representation of a macro is not to be expanded. Instead the integer value of the macro formal parameter number is returned. ASGENT This routine is used to assign the macro body to the macro formal parameter.  ^INTSCN: SETOM ASGFLG ; POPJ P, ; ^ASGENT: MOVE LPSA,GENLEF+1 ; ASSIGNC NEW BODY EXCH SP,STPSAV ; SET UP TO USE STRING STACK MOVSS POVTAB+6 ; MOVE TBITS,$TBITS(LPSA) ; SEE IF STRING AND IF NOT CONVERT TRNE TBITS,STRING ; TO A STRING JRST ASGCON ; IT IS A STRING PUSH P,$VAL(LPSA) ; NO, CONVERT TO A STRING, PUSHJ P,REMOPL ; REMOVE NUMERIC SEMBLK PUSHJ P,CVS ; WILL LEAVE RESULT STRING ON SP-STACK ;; #TA# (CMU = D1=) (2 OF 2) NEED 177 0 AT END OF ACTUAL PUSH SP,[XWD 0,2] PUSH SP,[POINT 7,[BYTE (7) 177,0]] PUSHJ P,CAT ;; #TA# JRST POPSTR ASGCON: PUSH SP,$PNAME(LPSA) ; STACK THE STRING PUSH SP,$PNAME+1(LPSA) ; ;; #QV# (1 OF ) PUSH SP,[XWD 0,2] PUSH SP,[POINT 7,[BYTE (7) 177,0]] PUSHJ P,CAT EXCH SP,STPSAV ; PUSHJ P,REMOPL ; REMOVE BODY SEMBLK IF NO ONE ELSE USES IT ;; #QV# EXCH SP,STPSAV ; POPSTR: MOVE LPSA,DEFRNG ; GET SEMBLK OF ACTUAL MOVE B,GENLEF+2 ; PARAMETER TO BE ASSIGNED TO, GETIT: SOJE B,GOTIT ; REPLACE ITS $PNAME WITH NEW VALUE RIGHT ,%RVARB, ; WHICH IS ON TOP OF SP STACK JRST GETIT ; GOTIT: POP SP,$PNAME+1(LPSA) ; POP SP,$PNAME(LPSA) ; EXCH SP,STPSAV ; MOVSS POVTAB+6 ; ;; #QV ! TURN OFF ASGFLG AT APROPRIATE TIME (NOT HERE) POPJ P, DSCR LETSET, LETENT PRO LETSET LENENT DES EXECS for syntax LET ident=, .... , ... ; The semantics of the reserved word is copied into the identifier. This mechanism could be expanded to allow synonymating idents with characters, so that characters could be returned to the letter set, and to allow run-time expressions (LET FOO=1, FOO=FOO+1). LTR: @IDD EXEC LETSET SCCAN 2 LT1 #QCON LT1: SG = @RESERVED drarrow EXEC LETENT SCAN ....  ^LETSET: SETZM BITS ;NO BITS NOW PUSHJ P,ENTERS ;ENTER IT RANDOMLY SKIPN LPSA,NEWSYM ;BE CAREFUL ERR ;IN CASE ENTERS MAKES A MISTAKE MOVEM LPSA,GENRIG ;RESULT, SO TO SPEAK TLZ FF,NOMACR ;TURN OFF SPECIAL POPJ P, ;DONE ^LETENT: SKIPE GENLEF ERR ;; #MS# LET NOT COPYING TRIGGER BIT MOVE LPSA,SYMTAB ;PREPARE TO LOOK IT UP PUSHJ P,SHASH ;LOOK UP SYMBOL AGAIN, PNAME SHOULD ;STILL BE VALID MOVE TEMP,NEWSYM ;SEMBLK FOR RESERVED WORD MOVE TEMP,$TBITS(TEMP) ;THE TBITS ;; #MS# MOVE PNT,GENLEF+2 ;NEW NAME FOR SAME THING MOVEM TEMP,$TBITS(PNT) ;MAKE THEM EQUIVALENT POPJ P, ;RETURN ^TRIGOF: SETZM SWCPRS ; TURN OFF TRIGGERING ON IFC ... SETOM NODFSW ; TURN OFF TRIGGERING ON DEFINE, POPJ P, ; REDEFINE, EVALDEFINE, IFC ... SO ; THAT ONE CAN HAVE CONSTRUCTS ; SUCH AS LET DEFINE=REDEFINE ; LET IFC=IFCR ^TRIGON: SETOM SWCPRS ; TURN ON TRIGGERING ON IFC ... SETZM NODFSW ; TURN ON TRIGGERING ON DEFINE, POPJ P, ; REDFINE, AND EVALDEFINE DSCR TWCOND,SWICHP,SWPOFF,PSWICH,OKEOF PRO TWCOND SWICHP SWPOFF PSWICH OKEOF DES EXECS for conditional assembly TWCOND is responsible for indicating on the parse stack whether or not a condition is true. In the productions one assumes the condition is true, and thus if it is false then TWCOND will change the parse stack token to false. SWICHP switches parsers from the conditional parser back to the main sail parser. This entails saving the processor descriptor of the conditional parser (semantic stack pointer, parse stack pointer, production stack pointer, and number of calls to scanner that have still not yet been processed), as well as restoring the processor descriptor of the main sail parser. PSWICH does the reverse of SWICHP when one wants to switch from the main sail parser to the conditional parser. The actual code for this can be found in SYM at the end of the identifier scan routine. Note that this is not a procedure but it is described here for the sake of completeness. SWPOFF turns the switchparser switch (SWCPRS) off when one would want to switch to a parser that is already executing. This would typically happen when one has evaluated a condition to be false; since the conditional parser would now be in control and is in the process of swallowing characters until IFC ... ELSEC ... ENDC and nested occurrences are eliminated and an ENDC or ELSEC appears unnested. Thus what one has is a flag that says don't interrupt the con- ditional parser. OKEOF Is not strictly a part of conditional assembly. It was added to allow parser to see EOF as a token on some occasions. This allows code after DONES to scan to EOF, listing rest of file (final END bug). Will also lead the way to more parsers, like the conditional parser. OKEOF simply turns on SCNWRD's EOFOK bit...SCANNER then returns EOF token when appropriate.  ^TWCOND: GETSEM (1) ; GET SEMANTICS OF ARITHMETIC EXPRESSION MOVE TEMP,%CFLS1 ; ASSUME COMPARE FALSE (0 OR NOT CONSTANT) TLNE TBITS,CNST ; CONSTANT? SKIPN $VAL(PNT) ; ZERO? MOVEM TEMP,PARRIG ; YES, CHANGE FROM CTRU1 TO CFLS1 POPJ P, ; RETURN ^SWPOFF: SETZM SWCPRS ; TURN OFF SWITCH PARSEERS FLAG POPJ P, ; RETURN ^OKEOF: MOVE TEMP,SCNWRD ;TURN ON EOFOK FOR SCANNER (SCANNER ALWAYS TLO TEMP,EOFOK ; TURNS IT OFF, SO PRODUCTIONS MUST TURN MOVEM TEMP,SCNWRD ; IT ON EACH TIME (PROBABLY NOT NECESSARY, ;; #RA# (1 OF 1) SETOM EOFCEL ; POPJ P, ; BUT SCANNER SOMETIMES HAS TO TURN IT OFF ; UNDER CURRENT IMPL, SO...) ^SETFL: MOVE LPSA,GENLEF+2 ; MACRO PSEUDONYM SEMBLK MOVE LPSA,$VAL2(LPSA) ; ADDRES OF ACTUAL PARAMETER RING SEMBLK MOVEM LPSA,DEFRN2 ; STORE IT IN DEFRN2 JRST SETFL1 ; GO CONTINUE PREPARING FOR A MACRO CALL ^SETFR: MOVE LPSA,GENLEF+2 ; GET MACRO PSEUDONYM SEMBLK PUSHJ P,MKFRLP ; MAKE A FORC LOOP PARAMETER (I.E. LOOP VAR) POP SP,PNAME+1 ; SECOND WORD OF STRING DESCRIPTOR POP SP,PNAME ; FIRST WORD OF STRING DESCRIPTOR EXCH SP,STPSAV ; RETURN STRING POINTER (EXCH IN MKFRLP) MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE GETBLK NEWSYM ; GET A SEMBLK FOR THE FORC LOOP PARAMETER WHICH HRROI TEMP,PNAME+1 ; IS TREATED AS IF IT IS AN ACTUAL PARAMETER TO POP TEMP,$PNAME+1(LPSA) ; A MACRO AND IS THUS ALWAYS PUT ON THE STRING POP TEMP,$PNAME(LPSA) ; RING. NOTE THAT IT IS NOT HASHED AND IS MOVE TEMP,[XWD CNST,STRING] ; NOT PLACED ON THE STRING CONSTANT RING. MOVEM TEMP,$TBITS(LPSA) ; THUS WHEN ONE IS THROUGH WITH THE FORC BODY PUSHJ P,RNGSTR ; ITS LOOP PARAMETER'S SEMBLK IS FREED. MOVEM LPSA,DEFRN2 ; SETFL1: EXCH SP,STPSAV ; GET STRING POINTER MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE MOVE LPSA,GENLEF+1 ; GET FORC OR FORLC BODY STRING SEMBLK PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS ; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED PUSHJ P,CTENDC ; APPEND COND COMP ENDING (" ENDC 177 0") MOVE LPSA,GENLEF+2 ; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK JRST PRCAL1 ; GO CONTINUE PREPARING FOR A MACRO CALL ^SETCSE: EXCH SP,STPSAV ; GET STRING POINTER MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE MOVE LPSA,GENLEF+1 ; GET THE CASEC BODY STRING SEMBLK PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS ; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED PUSHJ P,CTENDC ; APPEND COND COMP ENDING (" ENDC 177 0") MOVE LPSA,GENLEF+3 ; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK JRST PRECAL ; GO CONTINUE PREPARING FOR A MACRO CALL ^SETWHL: EXCH SP,STPSAV ; GET STRING POINTER MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE PUSH SP,[XWD 0,4] ; LENGTH OF FOLLOWING STRING PUSH SP,[POINT 7,[ASCII "IFC "]] ; FIRST WORD OF PSEUDO MACRO MOVE LPSA,GENLEF+3 ; GET THE CONDITION STRING SEMBLK PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS ; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED PUSHJ P,CAT ; CONCATENATE PUSH SP,[XWD 0,7] ; LENGTH OF FOLLOWING STRING PUSH SP,[POINT 7,[ASCII " THENC "]] ; END OF CONDITION PUSHJ P,CAT ; CONCATENATE MOVE LPSA,GENLEF+1 ; GET THE PSEUDO MACRO BODY STRING SEMBLK PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS ; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED PUSHJ P,CAT ; CONCATENATE PUSHJ P,CTENDC ; APPEND COND COMP ENDING (" ENDC 177 0") MOVE LPSA,GENLEF+2 ; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK PRECAL: SETZM DEFRN2 ; WHILEC AND CASEC HAVE NO PARAMETER RINGS PRCAL1: POP SP,PNAME+1 ; FIRST WORD OF STRING DESCRIPTOR POP SP,PNAME ; SECOND WORD OF STRING DESCRIPTOR PUSH P,LPSA ; ENTER CONDITIONAL COMPILATION BODY STRING AND PUSHJ P,STRINS ; LINK TO MACRO PSEUDONYM SEMBLK POP P,LPSA ; HRLM PNT,%TLINK(LPSA) ; EXCH SP,STPSAV ; RETURN STRING POINTER MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE MOVE TBITS2,SCNWRD ; SYNCH SCAN COMTROL WORD JRST ACPMED ; GO PREPARE FOR A MACRO CALL (IN SCANNER) ^CTENDC: PUSH SP,[XWD 0,8] ; LENGTH OF FOLLOWING STRING PUSH SP,[POINT 7,[BYTE (7) " ","E","N","D","C"," ",177,0]] ; END ; OF PSEUDO MACRO BODY JRST CAT ; CONCATENATE ^SWICHM: MOVE LPSA,GENLEF+2 ; PSEUDO MACRO NAME SEMBLK JRST CONTXT ; PREPARE FOR WHILEC BODY SCAN ^SWCHFR: MOVE LPSA,GENLEF ; PSEUDO MACRO NAME SEMBLK PUSHJ P,MKFRLP ; GET NEW FORC LOOP PARAMETER MOVE LPSA,DEFRNG ; SEMBLK OF PSEUDO MACRO PARAMETER POP SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR POP SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR EXCH SP,STPSAV ; RETURN STRING POINTER (EXCH IN MKFRLP) MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE ^SWCHFL: MOVE LPSA,GENLEF ; PSEUDO MACRO NAME SEMBLK JRST CONTXT ; PREPARE FOR FORC OR FORLC BODY SCAN ^MKFRLP: EXCH SP,STPSAV ; GET STRING POINTER MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE PUSH P,$VAL2(LPSA) ; CURRENT VALUE OF FORC LOOP PARAMETER PUSHJ P,CVS ; CONVERT TO STRING PUSH SP,[XWD 0,2] ; LENGTH OF FOLLOWING STRING PUSH SP,[POINT 7,[BYTE (7) 177,0]] ; MACRO PARAMETER ENDING JRST CAT ; CONCATENATE ^GTSTRT: PUSHJ P,GETCVI ; CONVERT FORC STARTING VALUE TO INTEGER MOVEM PNT,$VAL2(LPSA) ; STORE IN $VAL2 OF MACRO PSEUDONYM SEMBLK POPJ P, ; RETURN ^GTSTEP: PUSHJ P,GETCVI ; CONVERT FORC STEP TO INTEGER MOVEM PNT,$DATA(LPSA) ; STORE IN $DATA OF MACRO PSEUDONYM SEMBLK POPJ P, ; RETURN ^GETERM: PUSHJ P,GETCVI ; CONVERT FORC END VALUE TO INTEGER MOVE LPSA,GENLEF+2 ; SEMANTICS OF MACRO PSEUDONYM MOVEM PNT,$DATA2(LPSA) ; STORE IN $DATA2 OF MACRO PSEUDONYM SEMBLK MOVE PNT,$VAL2(LPSA) ; GET FORC STARTING VALUE PUSHJ P,TWNUM1 ; GO CHECK IF STARTING VALUE IS OUT OF RANGE CAMN PNT,%CFLS1 ; STARTING VALUE OUT OF RANGE? PUSHJ P,FFPUSH ; NO POPJ P, ; RETURN ^GETCVI: MOVE PNT,GENLEF+1 ; STRING SEMBLK TO BE CONVERTED TO INTEGER GENMOV(CONV,INSIST!GETD,INTEGR) ; CONVERT MOVE PNT,$VAL(PNT) ; GET INTEGER VALUE MOVE LPSA,GENLEF+2 ; ADDRESS OF MACRO PSEUDONYM SEMBLK POPJ P, ; RETURN ^TWNUM: MOVE LPSA,GENLEF+1 ; ADDRESS OF FORC MACRO PSEUDONYM SEMBLK MOVE PNT,$DATA(LPSA) ; FORC LOOP STEP VALUE ADDB PNT,$VAL2(LPSA) ; INCREMENT CURRENT FORC LOOP VALUE ^TWNUM1: SUB PNT,$DATA2(LPSA) ; SUBTRACT FORC LOOP END VALUE SKIPL $DATA(LPSA) ; STEP NEGATIVE? MOVN PNT,PNT ; NO, NEGATE STEP JUMPGE PNT,GPOPJ ; DONE WITH LOOP IF POSITIVE MOVE PNT,%CFLS1 ; TWIDDLE TO INDICATE END OF FORC LOOP MOVEM PNT,PARRIG+1 ; SET PARSE STACK TO TWIDDLED VALUE GPOPJ: POPJ P, ; RETURN ^GETACT: MOVE LPSA,GENLEF+2 ; ADDRESS OF FORLC MACRO PSEUDONYM SEMBLK HRLZI TEMP,1 ; SET PARAMETER COUNT TO ZERO MOVEM TEMP,$VAL(LPSA) ; STORE IT (incredibly imaginative comment) MOVE TBITS2,SCNWRD ; SYNCH SCAN CONTROL WORD PUSHJ P,SCNACT ; SCAN A LIST OF ACTUAL PARAMETERS WHICH ; CAN HAVE A SPECIAL DELIMITER DECLARATION ; (IN SCANNER) MOVE TEMP,DEFRN2 ; DEFRN2 POINTS TO RING OF ACTUAL PARAMETERS MOVEM TEMP,$VAL2(LPSA) ; STORE IT IN $VAL2 OF FORLC MACRO PSEUDO- ; NYM SEMBLK SO THAT THE MACRO BODY CAN BE ; PROPERLY SCANNED FOR PARAMETER SUBSTITU- ; TIONS POPJ P, ; RETURN ^TWACT: MOVE LPSA,DEFRNG ; GET FORLC ACTUAL PARAMETER RING HRRZ LPSA,%RVARB(LPSA) ; GET NEXT PARAMETER IF NOT DONE JUMPN LPSA,.+3 ; FORLC ACTUAL PARAMETER LIST EXHAUSTED MOVE TEMP,%CFLS1 ; TOKEN TO BE TWIDDLED MOVEM TEMP,PARRIG+1 ; SET PARSE STACK STRAIGHT PUSH P,LPSA ; REMOVE CURRENT FORLC PARAMETER FROM THE STRING MOVE LPSA,DEFRNG ; RING AND FREE ITS STRING SEMBLK PUSHJ P,URGSTR POP P,LPSA; FREBLK DEFRNG ; MOVEM LPSA,DEFRNG ; SET DEFRNG TO CURRENT ACTUAL PARAMETER POPJ P, ; RETURN ^TWCSCN: MOVE TEMP,GENLEF+3 ; ADDRESS OF CASEC MACRO PSEUDONYM SEMBLK SOSE $VAL2(TEMP) ; RIGHT CASEC? POPJ P, ; NO, RETURN PUSHJ P,CPSHEN ; SET ENDC DOESN'T TRIGGER A PARSER SWITCH FLAG SETOM SWCPRS ; PARSER SWITCHING IS OK (I.E. IFC IN BODY OF CASEC ; TO BE EXECUTED) MOVE TEMP,%CTRU1 ; TWIDDLE SO NEXT CASEC WILL BE SCANNED MOVEM TEMP,PARRIG ; SET PARSE STACK STRAIGHT POPJ P, ; RETURN ^FREMBN: MOVE A,GENLEF+2 ; GET RID OF FORMAL PARAMETER LIST TO FORC MOVE LPSA,$ACNO(A) ; AND WHICH IS NEVER EXECUTED AS PUSHJ P,KILLST ; WELL AS RESTORE THE PROPER LEVEL AND MOVE LPSA,GENLEF+2 ; VARB PUSHJ P,CLENUP ; JRST FRMBFF ; ^FREMBF: SKIPA LPSA,GENLEF ; FORC, AND FORLC MACRO PSEUDONYM SEMBLK ^FREMBW: MOVE LPSA,GENLEF+2 ; WHILEC MACRO PSEUDONYM SEMBLK ADDRESS FRMBFF: PUSH P,LPSA ; CHECK IF THROUGH WITH PSEUDO MACRO STRING AND IF HLRZ LPSA,%TLINK(LPSA) ; YES FREE ITS SEMBLK SO THE STRING WILL BE PUSHJ P,REMOPL ; GARBAGE COLLECTED PUSHJ P,BLKFRE ; FREE MACRO PSEUDONYM SEMBLK MOVEI TEMP,2 ; AT THIS POINT ONE STILL HAS 177,0 TO SCAN SO SET HRRM TEMP,PNEXTC-1 ; PNEXTC-1 TO POINT TO THE 177,0 AS A STRING SO IT POPJ P, ; WON'T BE LOST IN CASE OF A GARBAGE COLLECTION ^FRMBCE:MOVE LPSA,GENLEF+3 ; CASEC SEMBLK ADDRESS SKIPLE $VAL2(LPSA) ; CHECK IF NONE OF THE CASEC CASES WERE PUSHJ P,CLENUP ; EXECUTED; IF SO RESTORE VARB AND LEVEL FREBLK GENLEF+3 ; DELETE CASEC PSEUDONYM SEMBLK POPJ P, ; RETURN ^FRMBCT: MOVE LPSA,GENLEF+2 ; LAST TRUE CASEC BODY SEMBLK HLRZ LPSA,%TLINK(LPSA) ; LAST TRUE CASEC BODY SEMBLK PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS ; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED MOVE LPSA,GENLEF+2 HRRZS %TLINK(LPSA) ; MACRO PSEUDONYM NO LONGER HAS A BODY LINK POPJ P, ; RETURN CLENUP: MOVE TEMP,$ADR(LPSA) ; RESTORE VARB AND LEVEL WHEN CASEC, FORC, MOVEM TEMP,VARB ; AND FORLC ARE NOT EXECUTED. EXPECTS SOS LEVEL ; LPSA TO CONTAIN THE ADDRESS OF THE ;; #SZ# CMU =C7= SAVE LPSA OVER CALL TO FREBUK PUSH P,LPSA ; SAVE OVER CALL TO FREBUK PUSHJ P,FREBUK POP P,LPSA POPJ P, ;; #SZ# ^TMACIN: SKIPE PRSCON ; DETERMINE WHICH PARSER IS CURRENTLY SUSPENDED AND SKIPA A,SSCWSV ; GET A POINTER TO ITS SCNWRD STACK. THIS IS USED MOVE A,CSCWSV ; TO SET THE MACIN BIT IN SYNCH WITH MACROS THAT POPJ P, ; MIGHT HAVE ENDED WHILE THE SUSPENDED OR MOST ; RECENTLY ACTIVATED PARSER WERE INACTIVE. ^TOMACN: PUSHJ P,TMACIN ; CHANGE MACIN BIT OF PARSER TO BE RESUMED TO LDB TBITS2,[POINT 1,SCNWRD,6] ; THE VALUE OF THE MACIN BIT OF THE DPB TBITS2,[POINT 1,(A),6] ; CURRENT PARSER. POPJ P, ; ^FRMACN: PUSHJ P,TMACIN ; CHANGE THE MACIN BIT OF THE CURRENT PARSER TO LDB TBITS2,[POINT 1,(A),6] ; THE VALUE OF THE MACIN BIT OF THE SUSPENDED DPB TBITS2,[POINT 1,SCNWRD,6] ; PARSER. POPJ P, ; SUBTTL EXECS for Entry Declaration DSCR ENTMAK, ENTOUT PRO ENTMAK ENTOUT DES EXECS for syntax ENTRY id1, id2, ...., ... ; Must appear before initial BEGIN SEE comment below DSCR for details  Comment  ENTRY code -- has two functions: 1. Denote that this compilation is not the main program but a collection of separately compiled procedures. 2. Create an entry block so that these programs can be loaded from a library. The syntax: BB0: ENTRY drarrow EXEC ENTENT SCAN 2  ENT BEGIN drarrow BLAT BEGIN EXEC ENTOUT DWN SCAN DS ... ENT: @I , drarrow EXEC ENTMAK SCAN 2  ENT @I ; drarrow EXEC ENTMAK SCAN  BB0  ^ENTENT: TLZE FF,MAINPG ;NO STARTING ADDRESS FOR THIS PROGRAM HLLZS ENTTAB ;RESET FIRST TIME IN POPJ P, ^ENTMAK: HRL LPSA,PNAME ;COUNT HRR LPSA,PNAME+1 ;BYTE POINTER FOR ENTRY SYMBOL PUSHJ P,RAD52 ;MAKE RADIX50 FOR ENTRY AOS B,ENTTAB ; PTR TO NEXT ENTRY HRRZS B ;CLEAR LEFT HALF MOVEM A,ENTTAB+1(B) ;TO ENTRY TABLE CAIGE B,22 ;FULL? POPJ P, ;NO ^ENTOUT: MOVEI B,ENTTAB ;PUT OUT BLOCK IF THERE IS TLNN FF,MAINPG ; ONE JRST GBOUT POPJ P, ;THERE IS NONE FOR SURE SUBTTL EXECS for Storage Allocation at end of Procedure DSCR ALOT DES Allocation routine -- called by PRUP and DONES EXECS, allocates storage, issues fixups and symbols for all locals in Procedure (outer Block) PAR VARB-rings on BLKLIS Qstack RES ALIMS, ALOCALS, SLIMS, SLOCALS, LLIMS, LLOCALS as described in subsequent comments SEE comment below DSCR for details  COMMENT  This is the code invoked to allocate space for variables on the VARB ring. Symbols are also output to the loader, for use by DDT and the world. As each block is closed, the portion of the VARB ring developed for that block is saved by a pointer in the table BLKLIS, and the count BLKIDX is incremented. It is the job of this code to run through all the VARB information stored on this list, and allocate. There is a bit in FF, called ALLOCT which determines whether this code actually allocates storage, or merely counts things. The counts are necessary for deciding how exit and entry code for recursive procedures should be generated. These counts are: ALOCAL (arithmetic stack locals) and SLOCAL (string stack locals). FIRSYM and LSTSYM point to the first and last symbols allocated.  ZERODATA (VARIABLE-ALLOCATION VARIABLES) COMMENT  ALIMS -- [Semantics of last,Semantics of first] -- set up by ALLOT to indicate the range of non-string variables allocated. This is used by PROCED after the first (non-allocating) call on ALLOT and before the second (allocating) call, to set up saving and restoring instructions (BLT) for these variables for recursive Procedures. The non-allocating run allows these extra instructions to be inserted before fixed locations are assigned to the variables (see ALLOT's DSCRs).  ^^ALIMS: 0 ;ALOCALS -- a count of the number of non-string locals -- set up ; for the same reasons given above for ALIMS ^^ALOCALS: 0 ;BLKCNT -- temp used when outputing symbol names -- see DOSYM's ; DSCR for details ?BLKCNT: 0 ;FIRSYM -- Semantics of first variable allocated by ALOT -- used to ; set up ALIMS, SLIMS, LLIMS ?FIRSYM: 0 ;LLIMS -- ALIMS-like thing for sets -- ALIMS includes LLIMS in its ; range -- used to put together Set Link Blocks -- see ALLOT ?LLIMS: 0 ;LLOCAL -- ALOCAL-type count of number of Sets this Procedure ?LLOCAL: 0 ;LSTSYM -- Semantics of last variable allocated by ALOT -- used to ; set up ALIMS, SLIMS, LLIMS ?LSTSYM: 0 ;SLIMS -- ALIMS-like thing for strings. Used for above- ; mentioned purposes; also to put together String Link Blocks ; See ALLOT, LNKOUT ^^SLIMS: 0 ;SLOCALS -- ALOCALS-type count for # Strings this Procedure ^^SLOCALS: 0 THSLVL: 0 ENDDATA ^ALOT: ;ROUTINE TO HANDLE ALLOCATION ;OF CORE AND THINGS FOR VARIABLES. SETZM FIRSYM OPTSYM %$ADCN ; BEGIN ADCONS TLNN FF,ALLOCT ;ALLOCATING REALLY? JRST ALSYMS ; NO, IGNORE ADCONS THIS TIME AROUND ;ALLOCATE ADDRESS CONSTANTS. INFORMATION ABOUT THEM IS ;SAVED ON THE VARB RING HOMED AT ADRTAB. SEE PROCED ;FOR DETAILS OF HOW THE ADDRESS CONSTANTS ARE USED. ADCGO: HRRZ LPSA,TPROC ;GET LEVEL OF PROCEDURE WHOSE LOCALS LDB TEMP,PLEVEL ; ARE BEING DEFINED MOVEM TEMP,THSLVL HRRZ LPSA,ADRTAB ;ADDRESS CONSTANTS. JUMPE LPSA,ALSYMS ;NONE RADA: MOVE SBITS,$SBITS(LPSA) ;IF A TEMP, IT IS IDENTIFIED BY TLNN SBITS,ARTEMP ;ITS SEQUENCE NO, ELSE BY SEMANTIC ADR JRST RADAA ;NOT A TEMP MOVE A,$PNAME(LPSA) ;THE ID NO FOR THIS TEMP MOVE PNT,TTEMP ;SEARCH THE TEMP LIST FOR IT RADLP: JUMPE PNT,NOUNLK ;NOT THERE, TRY LATER CAMN A,$PNAME(PNT) ;IS THIS THE RIGHT INFO? JRST RADAB ; YES, PUT OUT ADCON HLRZ PNT,%RVARB(PNT) ;NO, KEEP LOOKING JRST RADLP RADAA: HLRZ PNT,%TLINK(LPSA) ;GET POINTER TO RADAB: PUSHJ P,GETAD ;SEMANTICS OF SYMBOL WHOSE AD IS CONED. TLNE SBITS,CORTMP ;IS THIS A CORE TEMP? JRST OKRADA ; YES, PUT OUT THE ADCON TLNE SBITS,ARTEMP ; ***** BUG TRAP ERR ,1 TLNE TBITS,CNST JRST OKRADA ;EACH WILL APPEAR BUT ONCE TDZ SBITS,[LLFLDM] ;GET LEVEL ONLY CAMGE SBITS,THSLVL ;IF ADCON CORRESPONDS TO JRST NOUNLK ;SOMETHING IN THIS PROC, PUT IT OUT OKRADA: HRLZ B,$ADR(LPSA) ;ADCON FIXUP JUMPE B,RADC ;WAS NOT USED. HRR B,PCNT PUSHJ P,FBOUT ;FIXUP FOR THE ADCON. HLL A,$ADR(LPSA) ;TYPE BITS TO INSERT. HRRI A,FXTWO!NOUSAC ;; #NQ# ! A STRING ITEMVAR IS NOT A STRING ;;#UK# STRING PROCEDURE IS NOT A STRING -- PROCED ADDED NEXT LINE /RLS TDNN TBITS,[SBSCRP,,ITMVAR!PROCED] ;IF (SBSCRP OR ITEMVAR)AND STRING TRNN TBITS,STRING ; USE 2D WORD FIXUP TRZ A,FXTWO ;ELSE REGULAR OLD FIXUP ;;#SG# THE TYPE BITS MAY BE AN "IMMEDIATE-ABLE" OP CODE PUSH P,OPDUN ;PARANOIA STRIKES DEEP SETOM OPDUN PUSHJ P,EMITER ;USE HIM TO OUTPUT THE WORD. POP P,OPDUN ;;#SG# RADC: PUSHJ P,URGADR ;REMOVE FROM ADRTAB FREBLK (LPSA) NOUNLK: LEFT ,%RVARB,ALSYMS ;LOOP UNTIL DONE. JRST RADA Comment  NOW ALLOCATE STORAGE FOR VARIABLES. When a block has been compiled, the pointer to its block entry (and thus to its VARB ring of locals) is placed in the next free location in BLKLIS (using BLKIDX QPDP). BLKIDX is cleared at the beginning of each procedure compilation, and the old value is stored. In all that follows, all and only those blocks whose pointers lie in the current BLKLIS will be processed. In order to keep things together for BLT'ing on and off the stacks, strings are allocated first. Then arrays. Then all else. The routine "ALLO" is called to actually look for things to allocate. It uses the mask set up in TBITS2.  ALSYMS: MOVEI TBITS2,STRING ;FIRST ALLOCATE STRINGS. OPTSYM %.ADCN ;END OF ADCONS REN < PUSHJ P,LOSET ;SWITCH TO DATA SEGMENT >;REN SETZM CSPOS ;SET STACK DISPL=0 PUSHJ P,ALLO ;GO DO IT. LSH PNT2,1 MOVEM PNT2,SLOCAL ;SAVE COUNT OF STRINGS ALLOCATED. MOVEM A,SLIMS ;LIMITS OF SYMBOLS.FOR STRINGS MOVE PNT2,CSPOS ; MOVEM PNT2,SSDIS ;STRING STACK DISPL DUE TO LOCALS MOVEI PNT2,2 ;FOR MCSP SIZE SKIPE SIMPSW ;IF SIMPLE HRRZI PNT2,0 ;THEN NO MSCP MOVEM PNT2,CSPOS ;SET CNTR AL1: SETZM FIRSYM SETZM LSTSYM MOVEI TBITS2,SET!LSTBIT ;ALLOCATE SETS FIRST AMONG "ARITHMETICS" PUSHJ P,ALLO HRLZM PNT2,LLOCAL ;FOR SETS ONLY. MOVEM A,LLIMS MOVEM PNT2,ALOCAL ;START LOCAL COUNT FOR ARITHS. OPTSYM %$VARS ;BEGIN SIMPLE VARIABLES MOVSI TBITS2,SBSCRP ;ALLOCATE ARRAYS. PUSHJ P,ALLO ADDM PNT2,ALOCAL ;COUNT OF ARITH. LOCALS. MOVEI TBITS2,-1  (STRING!LSTBIT!SET) ;ALL OTHERS. PUSHJ P,ALLO ADDM PNT2,ALOCAL ;AND UPDATE LOCAL COUNT PUSHJ P,TMPALO ;ALLOCATE TEMPS. ADDM PNT2,ALOCAL ;AND UPDATE LOCAL COUNT MOVE A,FIRSYM HRL A,LSTSYM MOVEM A,ALIMS ;LIMITS OF ARITH. LOCALS. MOVE PNT2,CSPOS ;PICK UP STACK LOC MOVEM PNT2,ASDIS ;SAVE IT AS ARITH STACK DISPL FOR LOCALS OPTSYM %.VARS ;END SIMPLE VARIABLES REN < PUSHJ P,HISET ;BACK TO CODE SEGMENT >;REN TLNN FF,ALLOCT ;ACTUALLY ALLOCATING ? POPJ P, ;NO -- DONE COMPLETELY. HRRZ PNT2,TPROC ;THIS PROCEDURE BAIL< SKIPG TEMP,BAILON JRST .+2 ;USE REGULAR TEST TRNN TEMP,BBPDSM ;SKIP IF WANT PD FOR SIMPLE--THUS PD EVERY TIME >;BAIL SKIPN SIMPSW ;IF SIMPLE, NO PD PUSHJ P,PDOUT ;PUT OUT PROC DESC AL2: SETZM TTEMP ;RESTART TEMP LIST. SETZM BLKCNT ;NO BLOCKS LOOKED AT OR ALLOCATED QBEGIN (BLKIDX) ;FIND BOTTOM ELEMENT IN BLKLIM QSTACK NOBAIL< JUMPE B,CRECHK ; NO SYMBOLS TO ALLOCATE >;NOBAIL BAIL < COMMENT  Here lies the Bail symbol outputing stuff. Currently, it puts out 1 file: .SM1 Variable length tables of information  BAISYM: TLNE FF,BINARY ;ARE WE PUTING OUT SYMBOLS? SKIPG BAILON ;IS DEBUGGER ACTIVE? JRST DOSYM ;NOPE PUSH P,PNT2 PUSH P,TBITS2 MOVE LPSA, TPROC ;CURRENT PROCEDURE MOVE TBITS,$TBITS(LPSA) ;TYPE TLNE TBITS,EXTRNL ;DON'T BOTHER WITH EXTERNAL PROCS JRST [CAIE LPSA,RESYM ;IF THE OUTER BLOCK PROC,DO IT JRST BLCDUN JRST .+1] SETZ SBITS, HLLM SBITS,BCORDN ;WE ARE NO LONGER DOING COORDS ; SINCE WE WANT SYMBOLS PUT OUT SO THAT ;INNERMOST BLOCK SYMBOLS APPEAR FIRST, WE DELAY THE ;FORMALS UNTIL AFTER THE LOCALS BLCKDN: QTAKE (BLKIDX) ;GET NEXT BLOCK JRST BFORMS ;NO MORE BLOCK! HRRZ LPSA,A ;GET THE BLOCK SEMBLK ;;#WH# 2! JFR 2-10-76 HLRZ TEMP,%TLINK(LPSA) ;IS THERE A SECOND BLOCK SEMBLK? JUMPE TEMP,BLCKDN ;NO, IGNORE. (currently SCB's only) MOVE TEMP,BAILON ;SEE IF THIS BLOCK IS WANTED: TRNE TEMP,BBSYM ;ALL SYMBOLS WANTED ALL THE TIME? JRST BLCKD1 ;YES MOVE TBITS,$VAL(LPSA) ;THE "OR" OF ALL SYMBOLS DEFINED HERE TLNE TBITS,INTRNL ;ANY INTERNALS HERE? JRST BLCKD1 ;YES, ALWAYS PUT THEM OUT HRRZ SBITS,%RVARB(LPSA) ;SEMBLK OF FIRST VARIABLE, IF ANY JUMPE SBITS,BLCKDN ;IF NO VARS AND NOT(BBSYM), SKIP BLOCK TOO BLCKD1: SETZ SBITS, PUSHJ P,VALOUT ;END PREVIOUS BLOCK MOVEI SBITS,BAIBLK PUSHJ P,VALOUT ;START BLOCK NAME SKIPE $PNAME(LPSA) ;DOES BLOCK ALREADY HAVE A NAME? JRST BBNMYS ;YES ;CREATE A NAME FOR THIS BLOCK -- TRICKY! ;;#WJ# ! JFR 2-25-76 MOVE USER,GOGTAB PUSHJ P,INSET ;USES ONLY TEMP ; ## NO! ALSO USES C ## HLRZ PNT2,%TLINK(LPSA) ;SECOND BLOCK SEMBLK HRRZ TBITS,$VAL2(PNT2) ;COORDINATE AT BEGIN ;;#%%# 2! BY JFR 1-24-75 FORGOT TO PUT BYTE POINTER INTO SEMBLOCK ;;#VH# WE WILL GET THESE FROM PNAME AT THE APPROPRIATE TIME ; MOVE TEMP,TOPBYTE(USER) ; MOVEM TEMP,$PNAME+1(LPSA) ;;#VH# MOVEI TEMP,"B" IDPB TEMP,TOPBYTE(USER) ;NAME BEGINS WITH "B" PUSH P,B ;SAVE FOR THE QTAKE AT BLCKDN MOVEI B,[IDPB TBITS,TOPBYTE(USER) ;ROUTINE TO DISPENSE CHARS POPJ P,] MOVEI PNT2,4 ;4 CHARS PUSHJ P,FRNPD ;GET ASCII POP P,B ;GET OUR AC BACK ;;#VH# TOO TRICKY BY HALF, FORGOT TO UPDATE REMCHR OR RESTORE TOPBYTE PUSH P,LPSA ;MAY BE TOO PARANOID HRRZI C,5 ;MAKE COUNT HONEST PUSHJ P,UPDCNT ;LIKE SO POP P,LPSA HRROI TEMP,PNAME+1 ;COPY PNAME INTO $PNAME POP TEMP,$PNAME+1(LPSA) ; POP TEMP,$PNAME(LPSA) ;NOW HAVE A GOOD ID ; HRROI TEMP,5 ;NAME IS 5 CHARS LONG ; MOVEM TEMP,$PNAME(LPSA) ;LENGTH OF NAME ;;#VH# ^ RHT BBNMYS: HRRZ SBITS,$PNAME(LPSA) ; # CHARS ADDI SBITS,4 IDIVI SBITS,5 ; # WORDS HRRZ PNT2,$VAL2(LPSA) ;DDT LEVEL DPB PNT2,[POINT 6,SBITS,35-6] HLRZ TEMP,%TLINK(LPSA) ;SECOND BLOCK SEMBLK HRL SBITS,$VAL2(TEMP) ;COORDINATE PUSHJ P,VALOUT ;FIRST WORD OF BLOCK BLOCK ;;#WK# 1! JFR 2-25-76 HRRZ SBITS,$ADR(TEMP) ;ADDR OF FIRST WORD OF CODE HLL SBITS,$VAL2(TEMP) ;ADDR OF LAST WORD OF CODE PUSHJ P,VALOUT ;SECOND WORD PUSHJ P,NAMOUT ;FOLLOWED BY NAME HRRZ SBITS,%RVARB(LPSA) JUMPE SBITS,BLCKDN ;TEST FOR ANY VARIABLES LOCAS: HRRZ LPSA,%RVARB(LPSA) ;GET NEXT VARIABLE JUMPE LPSA,BLCKDN ;END OF LOCALS MOVE TBITS,$TBITS(LPSA) TRNE TBITS,SET ;DON'T LET KILL SETS OUT TRNN TBITS,INTEGR TLNE TBITS,DEFINE ;DON'T PUT OUT ANY OF THESE JRST LOCAS TLNE TBITS,EXTRNL SKIPE $ADR(LPSA) JRST .+2 JRST LOCAS ;EXTERNALS ONLY IF REFERENCED TRNE TBITS,PROCED ;PROCEDURES ONLY IF EXTERNAL TLNE TBITS,EXTRNL JRST .+2 JRST LOCAS MOVE TEMP,BAILON TLNN TBITS,INTRNL ;SKIP IF INTERNAL TRNE TEMP,BBSYM ;SKIP IF NOT ALL SYMBOLS WANTED JRST .+2 ;SYMBOL IS INTERNAL OR ALL ARE WANTED JRST LOCAS HRRZ SBITS,$PNAME(LPSA) ; # CHARS ADDI SBITS,4 IDIVI SBITS,5 ; # WORDS PUSHJ P,VALOUT ; FIRST WORD FOR VARIABLE MOVE TBITS,$TBITS(LPSA) ;TYPE BITS FOR VARIABLE HRRZ SBITS,$ADR(LPSA) ;ADDR OF VARIABLE TRNE TBITS,ITEM ;ITEMS GET SPECIAL TREAMENT JRST [TLO SBITS,BITEM!BBILTN HRRZ TBITS,$VAL2(LPSA) ;GET INTEGER CONST SEMBLK HRR SBITS,$VAL(TBITS) ;GET THE ITEM NUMBER JRST .+2] PUSHJ P,TYPMNG ;***ALL THE TYPE MUNGING GOES HERE PUSHJ P,VALOUT PUSHJ P,NAMOUT ;PUT OUT THE NAME JRST LOCAS BFORMS: MOVE LPSA,TPROC ;FIRST PROCEDURE SEMBLK HRRZ PNT2,$VAL(LPSA) ;THE PD SEMBLK JUMPE PNT2,BLCDUN ;JUMP IF NO PD (I.E., BBPDSM OFF) MOVE TBITS,$TBITS(LPSA) ;TYPE BITS FOR THIS PROC TRNE TBITS,FORTRAN ;FORTRAN PROCEDURE? JRST BLCDUN ;YES. GIVE UP SETZ SBITS, PUSHJ P,VALOUT ;FLAG END OF PREVIOUS BLOCK MOVEI SBITS,BAIPRC PUSHJ P,VALOUT ;START BLOCK INFO HRRZ SBITS,$PNAME(LPSA) ; # CHARS ADDI SBITS,4 IDIVI SBITS,5 ;# WORDS ;;#%%# ! PNT2 GOT CLOBBERED BY THAT DIVIDE JFR 11-13-74 HRRZ PNT2,$VAL(LPSA) ;THE PD SEMBLK HLL SBITS,$VAL(PNT2) ;COORDINATE HLRZ TEMP,%TLINK(LPSA) ;SECOND PROC SEMBLK HRRZ TEMP,$VAL2(TEMP) ;DDT LEVEL DPB TEMP,[POINT 6,SBITS,35-6] TRO SBITS,400000 ;FLAG FOR PROCEDURE PUSHJ P,VALOUT ;FIRST WORD ;;#%%# ! JFR 2-23-75 REALLY USE THAT LAST WORD OF CODE FIELD HLL SBITS,$VAL2(PNT2) ;LAST WORD OF CODE HLR SBITS,$VAL2(LPSA) ;PCNT AT PRDEC (=FIRST WORD OF CODE) PUSHJ P,VALOUT ;SECOND WORD MOVE TBITS,$TBITS(LPSA) HRLI SBITS,BISPRC ;[CLH] THIS IS A PROCEDURE PUSHJ P,TYPMNG ;GET THE BITS FOR IT ;;#%%# ! JFR 2-16-75 RECURSIVE PROCS GET MARKED AS ON STACK, BUT WE KNOW ARE BILTIN TLZ SBITS,700 ;;#%%# BY JFR 2-1-75 ADD A WAY TO DISTINGUISH SIMPLE PROCEDURES TLNE TBITS,SIMPLE TLO SBITS,400000 ;;#%%# ^ HRR SBITS,$ADR(PNT2) ;PDA BFORM1: PUSHJ P,VALOUT ;THIRD WORD PUSHJ P,NAMOUT ;NAME HLRZ LPSA,%TLINK(LPSA) ;2ND PROC BLOCK HLRZ LPSA,%TLINK(LPSA) ;1ST FORMAL PARM FORMS: JUMPE LPSA,BLCDUN ;ANY MORE? HRRZ SBITS,$PNAME(LPSA) ; # CHARS ADDI SBITS,4 IDIVI SBITS,5 ; # WORDS PUSHJ P,VALOUT HRRZ SBITS,$ADR(LPSA) ;PUT ADR IN RH & BITS IN LH MOVE TBITS,$TBITS(LPSA) TRNE TBITS,PROCED ;PROCEDURES GET SPECIAL TREATMENT JRST [TLO SBITS,BISPRC!BREF ;[CLH] JRST .+2] PUSHJ P,TYPMNG ;******* TYPE MUNGING GOES HERE PUSHJ P,VALOUT PUSHJ P,NAMOUT ;PUT OUT NAME HRRZ LPSA,%RVARB(LPSA) ;GET NEXT FORMAL JRST FORMS BLCDUN: QBEGIN (BLKIDX) ;RESET BLKLIS POP P,TBITS2 POP P,PNT2 JUMPE B,CRECHK ;JUMP IF NO SYMBOLS TO PUT OUT JRST DOSYM ;GO GIVE RAID IT'S SYMBOLS ^NAMOUT: HRRZ PNT2,$PNAME(LPSA) ;CHAR COUNT MOVE SBITS2,$PNAME+1(LPSA) ;POINTER NN: MOVE D,[POINT 7,SBITS] SETZ SBITS, ; CLEAR TEMP DESTINATION MOVEI C,5 ; # CHARS PER WORD NN1: ILDB A,SBITS2 ;LOAD CHAR ;;#%%# BY JFR 2-1-75 FORCE UPPER CASE AND CHANGE ! TO  [FOR BLOCK NAMES, MOSTLY] ;;#%%# JFR 4-6-75 FORCE IT THE OTHER WAY; ASCII'IZE THINGS AS MUCH AS POSSIBLE CAIN A,"" MOVEI A,"!" CAIL A,"a" CAILE A,"z" JRST .+2 TRZ A,40 ;;#%%# ^ IDPB A,D ;DEPOSIT INTO SBITS SOSE C ;CHECK IF FULL WORD FORMED SOJG PNT2,NN1 ;CHECK IF DONE WITH NAME PUSHJ P,VALOUT ;WRITE FULL WORD SOJG PNT2,NN ;START NEW WORD IF NOT DONE POPJ P, ^VALOUT: NOTENX< SOSG SM1CNT OUTPUT SM1, IDPB SBITS,SM1PNT POPJ P, >;NOTENX TENX< IDPB SBITS,SM1PNT ;PLUNK IT DOWN SOSG SM1CNT PUSHJ P,VALOU1 ;DUMP BUFFER POPJ P, ^VALOU1: PUSH P,1 PUSH P,2 PUSH P,3 ;SAVE THESE ACS MOVE 1,SM1JFN MOVE 2,[POINT 36,SM1BUF] MOVE 3,SM1CNT SUBI 3,SM1SIZ ;AC3=NEGATIVE WORD COUNT JSYS SOUT MOVE 1,[POINT 36,SM1BUF] MOVEM 1,SM1PNT MOVEI 1,SM1SIZ MOVEM 1,SM1CNT POP P,3 POP P,2 POP P,1 POPJ P, >;TENX COMMENT  TYPMNG is the routine that translates Compiler types into Bail types. Procedures and items have been filterd out ahead of time. There are 3 trees: (right branch indicates that SAIL bit was off) COMPLEX TYPE:  SBSCRP | | ITMVAR ITMVAR |  |  LPARRY BARRY LPARRY BSIMPL     BARITA BITMAR BARITM BITMV SIMPLE TYPE: SET | | LSTBIT STRING  |  | BLIST FLOTNG BSTRNG INTEGR    | BCNTXT BSET BINTGR FLOTNG  | BREAL | | | | PNTVAR | | SHORT LABEL     BRCLAS BRPNTR BLABEL BLAMDA ACCESS TYPE: REFRNC |  | BREF EXTRNL | | | | | PROCED |   | BXPROC BEXTRN VALUE |  | BSTAK OWN |  | BBILTN  |  | BSTAK SBSCRP!SET |   BALLOC BBILTN  BITDATA (BAIL TYPES) BISPRC __200000 ;[CLH] IS A PROCEDURE ;COMPLEX BSIMPLE __0 BARRY __1 BITMV __2 BARITM __3 BITMAR __4 BARITA __5 BPROCED __6 ;[CLH] NO LONGER USED BITEM __7 BBLOCK __BPROCED+10; ;SIMPLE BLAMDA __00 BINTGR __10 BREAL __20 BSTRNG __30 BLIST __40 BSET __50 BCNTXT __60 BLABEL __70 BRPNTR __2000 ;RECORD POINTER (ALGOLW REFERENCE) BRCLAS __2010 ;RECORD CLASS BLREAL __2020 ;ACCESS BBILTN __000 BREF __100 BALLOC __200 BSTAK __300 BEXTRN __400 BXPROC __500 BBLTPRC __600 ;BILTIN PROCEDURE (PRESENTLY USED ELSEWHERE ONLY) BRCFLD __700 ;FIELD OF RECORD CLASS ;SM1 BLOCK TYPES ^^BAIFIL__1 ;FILE INFO BLOCK ^^BAICRD__2 ;COORDINATE BLOCK ^^BAIBLK__3 ;BLOCK NAME, THEN IDENTIFIERS ^^BAIPRC__4 ;PROCEDURE NAME, THEN PARAMETERS ENDDATA TYPMNG: ;INPUT TYPE IN TBITS, OUTPUT IN SBITS TLNE TBITS,SBSCRP JRST B1. TRNE TBITS,ITMVAR JRST B2. TLO SBITS,BSIMPL JRST SIMTYP B1.: TRNE TBITS,ITMVAR JRST B3. TLO SBITS,BARRY JRST SIMTYP B2.: TRNE TBITS,LPARRAY TLOA SBITS,BARITM TLO SBITS,BITMV JRST SIMTYP B3.: TRNE TBITS,LPARRAY TLOA SBITS,BARITA TLO SBITS,BITMAR SIMTYP: TRNE TBITS,SET JRST B4. TRNE TBITS,DBLPRC JRST [TLO SBITS,BLREAL JRST ACCTYP] TRNE TBITS,INTEGR JRST [TLO SBITS,BINTGR JRST ACCTYP] TRNE TBITS,STRING JRST [TLO SBITS,BSTRNG JRST ACCTYP] TRNE TBITS,FLOTNG JRST [TLO SBITS,BREAL JRST ACCTYP] ;;%##% JFR 2-16-75 RECORD CLASSES AND REFERENCES TRNE TBITS,PNTVAR JRST [TRNE TBITS,SHORT TLOA SBITS,BRCLAS TLO SBITS,BRPNTR JRST ACCTYP] ;;%##% ^ TRNE TBITS,LABEL ;;#WU# 2! JFR 5-27-76 LABELS ARE KNOWN TO BE BILTIN, DON'T BOTHER WITH ACCTYP JRST [TLO SBITS,BLABEL!BBILTN POPJ P,] ;WE ASSUME $ADR HAS ADDRESS OF LABEL... TLO SBITS,BLAMDA JRST ACCTYP B4.: TRNE TBITS,LSTBIT JRST [TLO SBITS,BLIST JRST ACCTYP] TRNE TBITS,FLOTNG TLOA SBITS,BCNTXT TLO SBITS,BSET ACCTYP: TLNE TBITS,REFRNC JRST [TLO SBITS,BREF POPJ P,] TLNE TBITS,EXTRNL JRST [TRNE TBITS,PROCED TLOA SBITS,BXPROC TLO SBITS,BEXTRN POPJ P,] TLNE TBITS,VALUE JRST [TLO SBITS,BSTAK POPJ P, ] TLNE TBITS,OWN JRST [TLO SBITS,BBILTN POPJ P, ] SKIPE RECSW ;RECSW IS ON IF DURING REC PROC COMPS JRST [ ;;#XS# JFR 11-7-76 RECORD CLASS INSIDE RECURSIVE PROC IS NOT REALLY ON STACK TLC SBITS,BRCLAS TLCN SBITS,BRCLAS JRST .+1 ;;#XS# ^ TLO SBITS,BSTAK TRO SBITS,400000 ;SIGNALS THAT THE STAC INC IS NEGATIVE POPJ P, ] TDNE TBITS,[XWD SBSCRP,SET] TLOA SBITS,BALLOC TLO SBITS,BBILTN POPJ P, >;BAIL Comment  ; NOW ISSUE SYMBOLS FOR THIS PROCEDURE At procedure declaration, and at the beginning of each NAMED block or compound statement, a count called NMLVL (name level) is incremented. Its current value is stored in $VAL2 of every block and NAMED compound statement. It is also stored in procedure blocks. It is decremented at appropriate times. When a block pointer is placed in BLKLIS (via BLKIDX QPDP), its left half is 0 if the block has a name, -1 otherwise (depends on higher-LEVELed block for name). A non-named block's NMLVL should be the same as that of the next named block in the list. Inner blocks appear in BLKLIS preceding outer ones. DDT (as it happens) requires that symbols for inner blocks appear first. So the algorithm for symbol allocation is: 1) Search from BLKLIS bottom to 1st named Block (index into SBITS2) 2) Put out Block name and level to .REL file 3) NMLVL of this block to TBITS2 4) For each BLKLIS entry from current backwards to bottom, or until an entry is found whose NMLVL is lower (outer block) that TBITS2, if the Block hasn't been handled (list entry 0), include its symbols in this DDT block on the .REL file. 5) Search forwards for the next named block (index into SBITS2). If one is found, go to step 2. 6) If some blocks were not handled, it is because the outer block of this procedure was not named. Put out procedure name as block name, and repeat step 3 once more to get the rest of the symbols. 7) Reset BLKIDX QPDP  ;STEP 1,5 -- FORWARDS SEARCH LOOP DOSYM: MOVEM B,SBITS2 ;B GETS CHANGED BY DOSYL1 DOSYML: MOVE B,SBITS2 ;GET QSTACK PDP FOR FORWARD SEARCH QTAKE (BLKIDX) ;LOOK AT NEXT BLOCK JRST DIDSYM ; HAVE LOOKED AT ALL, CHECK FOR REMAINING AOS BLKCNT ;ADD ONE FOR EACH ONE GLIMPSED MOVEM B,SBITS2 ;PROTECT THIS QPDP JUMPLE A,DOSYML ;IF NOT NAMED, CONTINUE FORWARD SEARCH MOVE LPSA,A ;STEP 2 PUSHJ P,BLBOUT ;ISSUE BLOCK NAME TO .REL FILE ;STEP 3 HRRZ TBITS2,$VAL2(LPSA) ;NMLVL (DDT LEVEL) OF THIS BLOCK MOVE B,SBITS2 ;BLBOUT CHANGES, MAYBE ;STEP4 -- BACKWARDS SEARCH LOOP DOSYL1: QBACK ;NONDESTRUCTIVE POP JRST DOSYML ; HAVE ALL BLOCKS, RETURN TO FORWARD SEARCH JUMPE A,DOSYL1 ;ALREADY DID THIS ONE MOVE LPSA,A ;BELONGS HERE FOR NOSY ETC. HRRZ TEMP,$VAL2(LPSA);NMLVL OF THIS BLOCK CAMLE TBITS2,TEMP ;IF NEW LEVEL LOWER, DON'T INCLUDE IT, JRST DOSYML ; RETURN TO FORWARD SEARCH HLRZ TEMP,B ;GET CURRENT "QSTACK" POINTER SETZM 1(TEMP) ;ZERO "POPPED" ENTRY SOS BLKCNT ;SUBTRACT ONE FOR EACH ONE ALLOCATED PUSH P,%TLINK(LPSA) ; PUSH P,B PUSHJ P,NOSY ;ALLOCATE SYMBOLS FOR THIS BLOCK POP P,B POP P,LPSA ;SEE IF HAD A SECOND SEMBLK TLNN LPSA,-1 ;IF NOT JRST DOSYL1 ;CONTINUE BACKWARDS SEARCH HLRZ LPSA,LPSA ;WE DID FREBLK ;DONE WITH IT NOW JRST DOSYL1 ;CONTINUE BACKWARDS ;STEP 6 -- PUT OUT PROCNAME BLOCK IF NOT ALL GONE DIDSYM: SKIPG BLKCNT ;DID WE SEE SOME WE DIDN'T ALLOCATE? JRST DIDALL ; NO, ALL DONE SETOM BLKCNT ;WON'T FAIL AGAIN MOVE LPSA,TPROC ;USE PROCEDURE NAME AS OUTER BLOCK NAME PUSHJ P,BLBOUT MOVNI TBITS2,1 ;VERRRY LOW LEVEL MOVE B,BLKIDX ;LOOK AT ALL POSSIBLE ENTRIES JRST DOSYL1 ;GO ROUND ONCE MORE, GET THE REST ;STEP 7 -- CLEAN UP DIDALL: QFLUSH (BLKIDX) ;RELEASE STORAGE, CLEAR QPDP SKIPE SIMPSW ;NO PD FOR SIMPLE JRST CRECHK ; CRECHK: TLNN FF,CREFSW ;IF CREFFING, DONE. POPJ P, ;DONE MOVE LPSA,TPROC ;PROCEDURE NAME CAIE LPSA,RESYM ;NOT THIS ONE; JRST CREFBLOCK ;FOR BLOCK EXIT. APOPJ: POPJ P, NOSY: PUSHJ P,URGSTR ;IF ON STRING RING.... FREBLK ;DELETE THE BLOCK. RIGHT ,%RVARB,APOPJ ;GO TO NEXT BLOCK.(OR POPJ) SY2A: MOVE TBITS,$TBITS(LPSA) TLNE FF,CREFSW ;IF CREFFING. PUSHJ P,CREFDEF ;DEFINE THE SYMBOL. TLNE TBITS,RES ;IF RESERVED WORD (NEW DEF), JRST NOSY ; (VIA LET) , FORGET IT TLNE TBITS,SBSCRP ;TURN OFF STRING IF ARRAY TRZ TBITS,STRING PUSHJ P,RAD50 ;MAKE SURE A SYMBOL NAME GETS MADE IMSSS< TRNE TBITS,ITEM ;IS IT AN ITEM AT IMSSS? TLO A,400000 ;YES, TURN OFF PRINTOUT DDT >;IMSSS TRNE TBITS,ITEM TLNE TBITS,FORMAL!SBSCRP!EXTRNL ;PUT OUT ITEM NUMBER IF JRST NOITMS ;IT IS THERE. HRRZ TEMP,$VAL2(LPSA) ;POINTER TO INTEGER. MOVE B,$VAL(TEMP) ;ITEM NUMBER. ;; # # BY JRL (1-25-73) CAMGE B,[20] TLO A,400000 ;HALF KILL ITEM NO. < 20 ;; # # PUSHJ P,SCOUT0 ;NO RELOCATION. JRST NOSY NOITMS: HRRZ B,$ADR(LPSA) ;FIXUP ;;#KY# ALLOW GLOBAL INTERNAL SYMBOLS OUT (FIX 1 OF 2) TRNE TBITS,GLOBL ; TLNN TBITS,INTRNL ; ;;#KY# 1 OF 2 JUMPE B,NOSY1 ;NO SYMBOL GLOC < TRNE TBITS,GLOBL ;IF NOT GLOBAL TRNE TBITS,ITEM ;OR IT ITEM, THEN JRST REGSYM ;NOT POSSIBLY A GLOBAL TYPE. HRLZ B,$ADR(LPSA) ;FIXUP CHAIN HLR B,$VAL2(LPSA) ; AND THE GLOBAL NUMBER. ADDI B,400013 ; GLOBAL DATA BASE. HRRM B,$ADR(LPSA) ;FOR THE SYMBOL.... ;;#KY# ! 2 OF 2 TLNE B,-1 ;ANY TO FIX UP? PUSHJ P,FIXOUT ;FIXUP WITH NO RELOCATION. PUSHJ P,SCOUT0 ;PUT OUT SYMBOL WITH NO RELOC. JRST NOSY REGSYM: >;GLOC ;;#II#! 7-4-72 DCS DON'T LET DEFINES OUT! TLNN TBITS,DEFINE PUSHJ P,SOUT ;OUTPUT THE SYMBOL. TRC TBITS,FORWRD!LABEL TRCN TBITS,FORWRD!LABEL ;HAS A LABEL BEEN USED BUT NOT DEFINED? ERR ,3 NOSY1: TRNE TBITS,PROCED JRST PPR ;PROCEDURE AND FRIENDS. REC < TRNE TBITS,PNTVAR ; TRNN TBITS,SHORT ;A RECORD CLASS ID JRST .+2 ;NO TDC TBITS,[XWD SIMPLE,PROCED!PNTVAR!SHORT] ;NOW WILL DEALLOCATE ;SEMBLKS IN PROPER MANNER >;REC TLNN TBITS,DEFINE ;DELETE THE MACRO BODY .... JRST CHARYZ ;CHECK ARRAYS. PUSH P,LPSA LEFT ,%TLINK,LPSERR PUSHJ P,REMOPL ;UNLINK MACRO BODY. POP P,LPSA JRST NOSY ;ALL DONE CHARYZ: TLNN TBITS,SBSCRP ;ARRAY? JRST CHKTWO ; NO PUSH P,LPSA HRRZ B,$VAL(LPSA) ;ARRAY ADDRESS IF OWN ARRAY MOVE A,RAD5. ;DOTTED SYMBOL NAME TLZ A,740000 ;MAKE AN INTERNAL SYMBOL! TLO A,100000 ;LIKE THIS TLNE TBITS,OWN ;BUILT IN? PUSHJ P,SCOUT ; YES, PUT OUT A SYMBOL LEFT ,%TLINK,NOBBLK ;DELETE BNDBLK (SEE ARRAY) FREBLK NOBBLK: POP P,LPSA ; IF THERE IS ONE CHKTWO: TLNE TBITS,INTRNL!EXTRNL ;IS THERE TRNN TBITS,STRING ;A SECOND SYMBOL? JRST NOSY ;NO -- DONE MOVE A,RAD5. ;GET KLUDGED UP VERSION OF SYMBOL HLRZ B,$ADR(LPSA) ;GET ADDRESS FOR 2D WORD JUMPE B,NOSY ;AN EXTERNAL STRING COULD CAUSE THIS PUSHJ P,SCOUT ;OUTPUT SYMBOL JRST NOSY PPR: TLNE TBITS,EXTRNL!MESSAGE ;DON'T MAKE THIS CHECK FOR EXTERNALS JRST PPR1 TRNE TBITS,FORWRD ;CHECK FOR FORWARD NEVER DEFINED ERR ,3 PPR1: PUSH P,LPSA LEFT ,%TLINK,LPSERR ;LPSA PNTS TO 2D PROC BLOCK MOVE A,LPSA ;SAVE POINTER LEFT (,%TLINK,PPR4) ;PTR TO FIRST PARAM OR NIL PPR2: COMMENT THIS COMMENT FLUSHES A POTENTIAL BUG BUT STILL LEAVES EVIL AROUND, IN THE FORM OF WASTED SPACE HRRZ B,$VAL2(LPSA) ;DOET THIS HAVE A DEFAULT VALUE JUMPE B,PPRX ;NO HRRZ C,$ADR(B) ;ZERO FIXUP ? JUMPN C,PPRX ;NO? EXCH B,LPSA ; FREBLK ;GET RID OF IT SKIPA LPSA,B ;LPSA _ FORMAL SEMBLK  PPRX: MOVE B,LPSA ;SAVE IT ;;#MC# ! NEED TO GET IT OFF STRING RING TOO RHT 4-20-73 PUSHJ P,URGSTR ;GET OFF THE STRING RING FREBLK ;KILL IT RIGHT (B,%RVARB,PPR4) ;GET NEXT JRST PPR2 PPR4: FREBLK (A) ;DELETE 2D PROC BLOCK ;THE FOLLOWING CODE HANDLES THE PROCEDURE DESCRIPTOR MOVE LPSA,(P) ;PICK UP PROCEDURE HRRZ A,$VAL(LPSA) ;PICK UP THE PD SEMBLK JUMPE A,NOPD TLNN TBITS,EXTRNL ;EXTERNAL? JRST NOEXPD ;NO SKIPGE C,$ADR(A) ;OUT ALREADY?? ERR ,1 TRNN C,-1 ;FIXUPS?? JRST PDFDON ;NO PUSH P,B PUSH P,A HRLM C,PDFFHD ;REMEMBER FIXUP HEAD PUSHJ P,RAD50 ;GET PROCEDURE RADIX50 TLC A,640000 ;CHANGE TYPE BITS HLRM A,R5PD1 ;SAVE RADIX50 IN BLOCK ;;#KM# RHT ! 11-24-72 USE "A" INSTEAD OF "B" HRLM A,R5PD2 MOVE B,PDPFBD ;POLISH FIXUP BLOCK DESC PUSHJ P,FRBT ;FLUSH BN OUTPUT PUSHJ P,GBOUT ;PUT OUT THE BLOCK POP P,A POP P,B JRST PDFDON NOEXPD: ;;#IV# RHT (9-22-72) IGNORE FORWARD PROCEDURES HERE TRNE TBITS,FORWRD JRST PDFDON ;;#IV# PUSH P,A PUSHJ P,RAD50 ;GET RADIX 50 SYMBOL MOVE A,RAD5$ ;THE $ SYMBOL TLZ A,740000 TLO A,100000 ;LOCAL PROCEDURE HRRZ B,$VAL(LPSA) SKIPL B,$ADR(B) ;THE ADDRESS ERR PUSHJ P,SCOUT ;PUT PD SYMBOL OUT POP P,A ; PDFDON: HLRZ C,%TLINK(A) ;POINT AT PDA,,0 SEMBLK FREBLK (A) ;FREE PD BLOCK JUMPE C,NOPD ;FREE PDA,,0 BLOCK IF HAVE ONE FREBLK (C) NOPD: POP P,LPSA GLOC < ;;#JF# RHT (9-27-72) ! BE SURE MESSAGE BLOCK GETS RIGHT ADDR HRRZ B,$ADR(LPSA) ; CAIE B,0 ;IF FORWARD MESSAGE DESCRIP. NEVER DEFINED TLNN TBITS,MESSAGE ;AND IS DEFINITELY A MESSAGE JRST NOSY ; -- TLO FF,RELOC ;FIRST GOES THE WORD WHICH CHAINS LINKS. HRRO A,PCNT EXCH A,MESLNK ;MESSAGE LINK PUSHJ P,CODOUT ;PUT IT OUT HRL A,$PNAME(LPSA) ;STRING COUNT HRR A,B ;ADDRESS OF PROCEDURE TLO FF,RELOC ;AGAIN SINCE IF MESLNK WAS ZERO, OUR FRIEND ;CODOUT RESET RELOC....... PUSHJ P,CODOUT ;XWD #CHARS,,PROD ADDRESS. TLZ FF,RELOC HRRZ C,$PNAME(LPSA) ;#CHARS AGAIN. ADDI C,4 ;.. IDIVI C,=5 MES21: AOS B,$PNAME+1(LPSA);WE CAN HAPPILY DESTROY THE BYTE POINTER. MOVE A,-1(B) ;FIRST WORD OF PNAMES. PUSHJ P,CODOUT ;OUT IT GOES. MOVE A,(B) ;NEXT WORD CAIGE C,2 ;... MOVEI A,0 ;NOT TWO WORDS LONG. PUSHJ P,CODOUT >;GLOC JRST NOSY ;AND LOOP. ^^OPTSY.:SKIPN WHERSW ;WANT ANY? POPJ P, ;NO PUSH P,A ;SAVE A,B PUSH P,B MOVE A,TEMP ;RADIX50 FOR SYMBOL HRRZ B,PCNT ;VALUE PUSHJ P,SCOUT POP P,B POP P,A POPJ P, ;;#UQ# JFR 8-1-75 THIS GETS MODIFIED!!!!!!!!!! DATA (LOADER BLOCK FOR POLISH FIXUP) ;LOADER BLOCK FOR POLISH FIXUP LODBLK(,11,PDPFB,PDPFBD,5,,) RELOC .-5 XWD 3,1 ;ADD , LITC -1 R5PD1: XWD 2,0 ;OPDC ,, LH OF RAD50 R5PD2: XWD 0,-1 ;RH OF RAD50,,SHR PDFFHD: XWD 0,0 ;DEST ,,0 ENDDATA ;;#UQ# ^ DSCR BLBOUT CAL PUSHJ PAR LPSA is Semantics of Block with a name DES outputs a Block name LOADER block via GBOUT. Saves RADIX50 for name, and SHOUT makes sure that no two consecutive blocks output with the same names. This can happen: PRODEDURE FINIS (..); BEGIN "FINIS" ... two identical block names cause havoc with DDT. SID Uses most ACs except SBITS, PNT2 group  BLBOUT: MOVE TBITS,$TBITS(LPSA) ;SEE IF IT IS A PROCEDURE OR NOT HRRZ B,$VAL2(LPSA) ;LEVEL (DDT) OF THIS BLOCK TRNN TBITS,PROCED ;IF PROCEDURE, ; GET LEVEL FROM DIFFERENT PLACE JRST NOPRCC HLRZ TEMP,%TLINK(LPSA) HRRZ B,$VAL2(TEMP) NOPRCC: PUSHJ P,RAD50 ;GET BLOCK NAME IN RADIX50 TLZ A,740000 ;CLEAR SYMBOL TYPE BITS TLO A,140000 ;PUT IN THE RIGHT ONES PUSHJ P,SCOUT ;PUT OUT BLOCK NAME MOVEM A,LSTRAD ;SAVE RADIX50 FOR THE BLOCK NAME. TRNE TBITS,PROCED POPJ P, MOVE A,RAD5. TLZ A,740000 ;SHOULD BE BLOCK TYPE 10 TLO A,100000 HLRZ B,$VAL2(LPSA) PPFF: JRST SCOUT ;MAKE LABEL FOR BLK OR CMPD STMT. DSCR PDOUT DES ROUTINE TO OUTPUT THE PROCEDURE DESCRIPTOR -- USED ONLY FOR DISPLAY SYSTEMS PARM PROC SEMBLK ADDRESS IN PNT2 SID ALL ACCUMULATORS SAVED EXCEPT TEMP & LPSA  PDOUT: PUSH P,FF ;SAVE FF PUSH P,A PUSH P,B PUSH P,C PUSH P,SBITS2 PUSH P,TBITS PUSH P,PNT HRRZ PNT,$VAL(PNT2) ;PICK UP PD SEMBLK JUMPE PNT,XPDOUT ;IF OUTER BLOCK, NOTHING GOES OUT REN< SKIPE OVRSAI ;OVERLAY? PUSHJ P,LOSET ; YES, FORCE LINK AND PD TO LOWSEG >;REN MOVEI A,0 TLZ FF,RELOC PUSHJ P,CODOUT MOVEI B,%PDLNK ;LINK THE PROC DESC PUSHJ P,LNKOUT HRRZ B,PCNT ;THE CURRENT ADDRESS HRL B,$ADR(PNT) ;FIXUP REFERENCES TO PDA HRROM B,$ADR(PNT) ;REMEMBER THE FACT THAT PDA IS RIGHT TLNE B,-1 ;IF THERE WERE ANY PUSHJ P,FBOUT ;DO IT HRRZ A,$ADR(PNT2) ;ADDRESS OF PROC ENTRY TLO FF,RELOC PUSHJ P,CODOUT HRRZ A,$PNAME(PNT2) ;LENGTH OF THE NAME TLZ FF,RELOC PUSHJ P,CODOUT ;PUT IT OUT HRRZ B,PCNT HRRM B,$PNAME+1(PNT) ;REMEMBER THIS SPOT MOVE A,[POINT 7,0] ;BYTE PTR WORD FOR PNAME PUSHJ P,CODOUT MOVEI B,PROCB MOVE A,$TBITS(PNT2) TRNE A,ITEM!ITMVAR TRO B,ITEMB TLNE A,MPBIND ;MATCHING PROC? TRO B,BINDB ;YEP PUSHJ P,ITMTYP ;SIX BIT TYPE ;;# # ! USED TO BE LSH A,5 JFR 9-11-74 LSH A,=23 ;INTO ITS SPOT TLO A,(B) ;OTHER BITS ;;%AA% A NEW FEATURE RHT -- SPROUT DEFAULTS 9-1-73 HLR A,$VAL(PNT2) ;ADD IN SPROUT DEFAULTS PUSHJ P,CODOUT ;PUT OUT PROCEDURE TYPE HLRZ B,%TLINK(PNT2) ;POINT AT 2ND PROC SEMBLK MOVS A,$NPRMS(B) ;#SPARMS*2,,#APRMS +1 INTO AC A PUSHJ P,CODOUT ;PUT IT OUT HRL A,SSDIS ;+SS DISP HRR A,ASDIS ;+AS DISP PUSHJ P,CODOUT ; LLPUT: HRLZ A,$SBITS(PNT2) AND A,[XWD LLFLDM,0] ;LEX LEV HRR A,$VAL2(PNT) ;LVI FIXUP HRL B,PCNT HLRM B,$VAL2(PNT) TLO FF,RELOC PUSHJ P,CODOUT DLPUT: HRLZ A,CDLEV ;CURRENT DISPLAY LEVEL HRR A,$VAL(PNT) ;PARAM INFO FIXUP HRL B,PCNT ; HLRM B,$VAL(PNT) TLO FF,RELOC PUSHJ P,CODOUT HLRZ B,%TLINK(PNT) ;POINT AT [PDA,,0] SEMBLK CAIN B,0 ;DO WE HAVE ONE JRST PDAX0 ;NO HRL B,$ADR(B) HRR B,PCNT ;HERE IT IS TLNE B,-1 PUSHJ P,FBOUT PDAX0: HRLZ A,$ADR(PNT) ;PICK UP PDA INTO LH PUSHJ P,CODLRL ;GO RELOCATE LH HLRZ C,%TLINK(PNT2) ;LOOK AT 2ND PROC SEMBLK HRRZ C,%SAVET(C) ;TO FIND PARENT PROC MOVEI A,0 ; JUMPE C,[ TLZ FF,RELOC ;IF THE TOP LEVEL (I.E. NO DADDY) PUSHJ P,CODOUT ;PUT OUT THE 0 JRST PCPRD] ;GO ON TO NEXT THING HRRZ C,$VAL(C) ;PD SEMBLK HRRZ A,$ADR(C) ;EASIEST TO CHAIN BY SELF HRR B,PCNT ;NEW CHAIN HRRM B,$ADR(C) HLL A,$ACNO(PNT) ;PCNT AT END OF MKSEMT PPDA0: TLO FF,RELOC PUSHJ P,CODLRL ;GO PUT IT OUT ;;%BI% ! (rht) used to be in $acno PCPRD: MOVE A,$VAL2(PNT2) ;PCNT AT PRDEC,,EXIT(FIXED UP) HRR A,$ACNO(PNT) ;PICK UP EXIT FROM PD SEMBLK TLO FF,RELOC PUSHJ P,CODLRL ;RELOC BOTH HALVES HLRZ C,%TLINK(PNT2) ;SECOND PROC SEMBLK HLRZ C,%SAVET(C) ;OLD TTOP HRLZ A,PCNT ; HLR A,$SBITS(C) ;FIXUP LVI REF TO PARENT BLOCK HLLM A,$SBITS(C) ;FIXUP CONTINUED HRRZS A ;SCRATCH THE OLD CRUFT PUSHJ P,CODOUT ;PUT IT OUT TLZ FF,RELOC HLRZ LPSA,%TLINK(PNT2) ;LPSA_ PTR TO 2ND PROC SEMBLK HLRZ LPSA,%TLINK(LPSA) ;LPSA NOW PNTS TO FIRST PARA JUMPE LPSA,DOLVIN ;THERE MAY NOT BE ANY HRR B,PCNT HRL B,$VAL(PNT) ;LOC OF START OF PROC PARAM INFO PUSHJ P,FBOUT PUSHJ P,TBCOUT ;GO PUT OUT INFO ON PARAMS PCPRD1: DOLVIN: PUSH P,PNT2 HRR B,PCNT HRL B,$VAL2(PNT) PUSHJ P,FBOUT MOVE PNT,$SBITS(PNT2) ANDI PNT,LLFLDM ;LEX LEVEL RGC < HRLZI A,RPCOD=9(PNT) ; LSH A,5 ; SKIPE RECSW TLOA A,RF TLOA FF,RELOC ;NOT RECURSIVE MEANS RELOC TLZ FF,RELOC ;RECSW MEANS DONT RELOC SKIPN LPSA,RCTEMP ;THE RECORD TEMPS WE BUFFERED UP JRST RCLV.2 RCLVLP: HRR A,$ADR(LPSA) ;THE CUPLRIT PUSHJ P,CODOUT ;PUT IT OUT HRRZ B,%TLINK(LPSA) ;REMEMBER THE NEXT FREBLK ;KILL OFF THE BLOCK SKIPE LPSA,B ;ITERATE JRST RCLVLP RCLV.1: HRLZI A,BLKCOD=14 TLZ FF,RELOC PUSHJ P,CODOUT SETZM RCTEMP RCLV.2: >;RGC SKIPE SBITS2,BLKIDX ;PICK UP PUSHJ P,LVIOUT POP P,PNT2 TLZ FF,RELOC MOVEI A,0 PUSHJ P,CODOUT ;PUT OUT END OF LVI FLAG MOVE PNT,$VAL(PNT2) ;PD SEMBLK AGAIN HRL B,$PNAME+1(PNT) ;FIX UP THE STRING REFERENCE HRR B,PCNT PUSHJ P,FBOUT HRRZ SBITS2,$PNAME(PNT2) ;LEN OF PNAME TLZ FF,RELOC ;DO NOT RELOCATE MOVE LPSA,$PNAME+1(PNT2) ;BYTE PTR FOR PNAME TRDY: MOVE TEMP,[POINT 7,A] MOVEI A,0 MOVEI B,5 TPNC: SOJL SBITS2,PNMDN ILDB C,LPSA ;PICK UP CHAR IDPB C,TEMP ;PUT IT DOWN SOJG B,TPNC PUSHJ P,CODOUT JRST TRDY PNMDN: CAIE B,5 PUSHJ P,CODOUT REN< SKIPE OVRSAI ;OVERLAY? PUSHJ P,HISET ; YES, POSSIBLE SWITCH BACK TO HISEG >;REN XPDOUT: POP P,PNT ;RETURN POP P,TBITS POP P,SBITS2 POP P,C POP P,B POP P,A POP P,FF POPJ P, ^TBCOUT: ;ROUTINE TO PUT OUT TYPE CODES FOR A RING OF THINGS ;TAKES LPSA= PTR TO FIRST SEMBLK ; USES LPSA,A,B NPTB: MOVE A,$TBITS(LPSA) ;PICK IT UP MOVEI B, TRNN A,ITEM!ITMVAR ;ITEMISH ? JRST NTITFP ;NO TRO B,ITEMB ;YES TLCE A,SBSCRP ;TEST THE ARY2 THING TROA B,ARY2B ; TLC A,SBSCRP ; TLNE A,MPBIND ;BINDING ITEMVAR TRO B,QUESB ;SAY SO NTITFP: TLNE A,REFRNC ;REFERENCE?? TRO B,REFB ;THE REF BIT TRNE A,PROCED ;PROCEDURE TRO B,PROCB ;GET TYPE PUSHJ P,ITMTYP ; LSH A,5 ;LEFT 5 TO GET OUT OF FULL ADDR TRO A,(B) ;THE OTHER BITS HRLZ A,A ;THE OTHER HALF! ;;%##% JFR 4-5-75 LET SIGN BIT SIGNIFY DEFAULTABLE ;; JFR 9-25-75 AND IF CALLED FROM PCPRD1, PUT ADDR OF DEFAULT IN RIGHT HALF HRRZ C,(P) ;RETURN ADDR CAIE C,PCPRD1 JRST NTITFQ ;NOT CALLED FROM PROC DESC OUTPUTTER HRRZ C,$VAL2(LPSA) ;SEMBLK OF DEFAULT VALUE, IF ANY JUMPE C,NTITFQ ;IS THERE ONE? TLO A,400000 ;YES HRR A,$ADR(C) ;FIXUP HRRZ B,PCNT MOVE TEMP,$TBITS(C) TRNE TEMP,STRING TDNE TEMP,[XWD SBSCRP,ITEM!ITMVAR!PROCED] JRST .+4 ;NOT A SIMPLE STRING HLR A,$ADR(C) ;WANT TO FIXUP WORD2 HRLM B,$ADR(C) JRST .+2 HRRM B,$ADR(C) ;FIXUP IF NOT STRING TLO FF,RELOC NTITFQ: ;;%##% ^ PUSHJ P,CODOUT ;PUT IT OUT TLZ FF,RELOC RIGHT ,%RVARB,CPOPJ JRST NPTB ;GO DO NEXT ONE ;ROUTINE TO PUT OUT LOCAL VAR INFO -- USED BY DIS ;PARAMS -- BLOCK QPDP IN SBITS2,, LEX LEV IN PNT LVIOUT: PUSH P,[-1] ;CLEVER FLAG TO CATCH BIG PARENT LVIO.1: MOVE B,SBITS2 QBACK JRST LVIEXT ;ALL DONE MOVEM B,SBITS2 MOVE PNT2,A ;GET HIS NAME LDB PNT,[POINT LLFLDL,$SBITS(PNT2),=35] HRRZ B,PCNT HLL B,$SBITS(PNT2) TLNE B,-1 PUSHJ P,FBOUT ;FIXUP REFS FOR THIS BLOCK'S INFO, IF ANY HRLM B,$SBITS(PNT2) ;REMEMBER MY SPOT HLRZ LPSA,%TLINK(PNT2) ;SECOND PROC SEMBLK JUMPE LPSA,LIT.1 ;NONE SKIPN $ACNO(LPSA) ;THE QPDP FOR CLEANUPS JRST LIT.1 ;NONE QBEGIN (<$ACNO(LPSA)>) ;GET INITIAL QPDP LIT.0: QTAKE ;TAKE ONE JRST LIT.X ;DONE MOVE TBITS,$TBITS(A) ;GET TYPE MOVE C,A ; HRRZ A,$ADR(C) ;ADDRESS TDNN TBITS,[XWD EXTRNL,FORWRD+INPROG] ;NEED FIXUP? JRST LIT.01 ;NO HRL C,PCNT ;YES HLRM C,$ADR(C) ; LIT.01: HRLI A,CLNCOD=14 ;TYPE IS CLEANUP DPB PNT,[ POINT =9,A,=12] ;LEX LEV TLO FF,RELOC ;RELOC PUSHJ P,CODOUT ; JRST LIT.0 ;GET NEXT LIT.X: QFLUSH LIT.1: MOVE LPSA,PNT2 LITER: RIGHT ,%RVARB,EBK ;GO DOWN VARB RING MOVE TBITS,$TBITS(LPSA) ;PICK UP TYPE BITS ;;#IT# RHT 8-4-72 ! KEEP OUT EXTERNALS ;;#IZ# RHT 9-25-72 ! ALSO KEEP OUT GLOBALS TDNE TBITS,[XWD EXTRNL!OWN,GLOBL!PROCED];OWN STUFF NEVER GOES, ; ALSO NO PROCS OR EXTERNALS JRST LITER TLNE TBITS,SBSCRP JRST ARYINF ;;# # DCS 5-3-72 SETS, BUT NOT SET ITEMS!! TRNE TBITS,ITMVAR!ITEM ;CHECK IT OUT -- DCS JRST LITER ;LOOP ;;# # 5-3 ;;%BI% REC < TRNE TBITS,PNTVAR ;PERHAPS A RECORDISH THING JRST RECINF ;WE SHALL SEE >;REC ;;%BI% TRNE TBITS,SET ;SET?? JRST SETINF TRNE TBITS,INTEGR ;TEST FOR THE FOREACH KLUGE (FLOATING INTEGER) TRNN TBITS,FLOTNG JRST LITER ;LOOP FRCINF: MOVEI B,FRCCOD ;FOREACH CODE JRST PUTCI REC < ;;%BI% RECINF: TRNE TBITS,SHORT ;A CLASSID? JRST LITER ;YES MOVEI B,RPCOD ;A REC PTR JRST PUTCI ; ;;%BI% >;REC ARYINF: TLNE TBITS,BILTIN ;BUILT IN JRST LITER ;YES,DONT BOTHER MOVEI B,AACOD ;ARITH CODE ;;#QJ# !2 RHT IF AN ITEMVAR ARRAY, BETTER DEALOCATE AS ARITHMETIC TRNE TBITS,ITEM!ITMVAR JRST PUTCI ;SO DONT DEALOCATE BASED ON DATUM TYPE TRNE TBITS,STRING ;MAYBE IT WAS A STRING ARRAY MOVEI B,SACOD TRNE TBITS,SET ;OR A LEAPISH THING MOVEI B,LACOD REC < TRNE TBITS,PNTVAR ;OR PERHAPS A RECORD ARRAY MOVEI B,RPACOD ; >;REC JRST PUTCI ;;# # RHT 8-1-72 KILL SET SETINF: TLNN TBITS,SAFE ;CHECK IF KILL SET JRST SETI.1 ;NO TRNN TBITS,INTEGR ;BE SURE ERR MOVEI B,KLCOD JRST PUTCI ;;# # RHT 8-1-72 ;;#RJ# USED ONLY TO PUT OUT IF RECURSIVE ! RHT 2-21-74 SETI.1: ; USED TO SKIPN RECSW HERE MOVEI B,CTXCOD ;CONTEXT? TRNE TBITS,FLOTNG ;CHECK JRST PUTCI MOVEI B,SETCOD PUTCI: MOVEI A,0 SKIPE RECSW ;IS THIS FORB RECURSIVE?? HRLZI A,RF DPB B,[POINT 4,A,3] DPB PNT,[POINT =9,A,=12] TLO FF,RELOC SKIPE RECSW TLZ FF,RELOC HRR A,$ADR(LPSA) TRNE A,-1 ;DID IT GET USED?? - IF SO MUST BE NON ZERO FOR ;EITHER CORE OR STACK (SINCE (F) IS DYN LINK) PUSHJ P,CODOUT JRST LITER EBK: HRLZ A,PNT LSH A,5 ;PUT LEX LEV IN RIGHT SPOT MOVEI B,BLKCOD ;SAY IT IS A BLOCK DPB B,[POINT 4,A,3] AOSN (P) ;IS THIS THE OUTER BLK FOR THIS PD JRST .+4 ;YES LINK UP IS ZERO HLRZ B,$ADR(PNT2) ; HLR A,$SBITS(B) ;RH OF A __ PARENT'S LVI AREA TLOA FF,RELOC ; TLZ FF,RELOC ;NEVER RELOC 0 PUSHJ P,CODOUT ;PUT OUT FLAG WORD JRST LVIO.1 ;GO GET NEXT BLOCK LVIEXT: SUB P,[XWD 2,2] ;FLUSH THE FLAG JRST @1(P) ;RETURN ;; %AA% -- SDFLTS ^SDFLTS: MOVE PNT,GENLEF+1; PUSHJ P,GETAD; BETTER HAVE AN INTEGER CONSTANT TRNN TBITS,INTEGR ERR ,1,CPOPJ MOVE A,$VAL(PNT) LSH A,-4 ;THE VALUE SHIFTED TO GET RID OF CONTROL OPTS SKIPE SIMPSW ;MAY NOT BE SIMPLE ERR ,1,CPOPJ MOVE PNT2,TPROC ;THE CURRENT PROCEDURE HRLM A,$VAL(PNT2) ;SAVE IT AWAY ;;#OB# RHT ! 10-31-73 NEED TO SETZM BITS JRST CLRSET ;DONE COMMENT Allo -- Allocate One Type of Symbol ALLO looks at each symbol and outputs its core locations, etc. It also outputs fixups, and saves the final core address in $ADR so that the symbol-outputter can find it.  ALLO: MOVEI PNT2,0 ;COUNT OF LOCALS ALLOCATED. SKIPN SBITS2,BLKIDX ;GET QPDP FOR BLOCK QSTACK JRST CPOPJ ; NOTHING TO ALLOCATE ITE: MOVE B,SBITS2 ;GET QPDP TO PARAM POSITION QBACK ;NON-DESTRUCTIVE QPOP JRST [HRR A,FIRSYM ;SET UP ALIMS-TYPE WORD HRL A,LSTSYM POPJ P,] ;DONE MOVEM B,SBITS2 ;SAVE UPDATED QPDP MOVE LPSA,A ITER: RIGHT ,%RVARB,ITE ;GO DOWN LIST MOVE TBITS,$TBITS(LPSA) ;TYPE BITS. REC < TRNE TBITS,PNTVAR TRNN TBITS,SHORT ;SHORT PNTVAR IS CLASS ID, NEVER GOES JRST .+2 TRZ TBITS,PNTVAR!SHORT >;REC TRNE TBITS,SET ;IF A SET DO NOT ALLOCATE AS ARITH TOO TRZ TBITS,FLOTNG!INTEGR TLNE TBITS,SBSCRP ;DO NOT ALLOCATE AS BOTH ARRAY AND INTEGER!!! NOREC < TRZ TBITS,STRING!INTEGR!FLOTNG!ITMVAR!ITEM!SET!LSTBIT!LPARRAY!SHORT!DBLPRC >;NOREC REC < TRZ TBITS,STRING!INTEGR!FLOTNG!ITMVAR!ITEM!SET!LSTBIT!LPARRAY!SHORT!PNTVAR!DBLPRC >;REC TRNE TBITS,ITEM!ITMVAR NOREC < TRZ TBITS,STRING!INTEGR!FLOTNG!SET!LSTBIT >;NOREC REC < TRZ TBITS,STRING!INTEGR!FLOTNG!SET!LSTBIT!PNTVAR >;REC TRNN TBITS,PROCED!LABEL ;NEVER SPACE FOR THESE. TDNN TBITS,TBITS2 ;USE THE MASK. JRST ITER ;NO MATCH -- GO FARTHER ALOWDS: TDNE TBITS,[XWD EXTRNL!DEFINE,GLOBL] ;PUT OUT NO CODE ; OR FIXUPS FOR EXTERNALS JRST ITER TLNE TBITS,SBSCRP ;ALWAYS ALLOCATE ARRAYS JRST ANYWAY SKIPN B,$ADR(LPSA) ;IF $ADR IS 0 AND SYMBOL IS NOT TLNN TBITS,INTRNL ; INTERNAL, DON'T PUT OUT CODE OR FIXUPS JUMPE B,ITER ANYWAY: SKIPE RECSW ;IF NOT RECURSIVE TDNE TBITS,[XWD OWN,ITEM] ;OR VAR IS OWN, ITEM OR THE LIKE JRST ALCV ;IT GETS INTO CORE AOS B,CSPOS ;USE A STACK LOCN TLNN FF,ALLOCT ;ALLOCATING? JRST [TRNE TBITS,STRING!DBLPRC ;NO-- IS IT A STRING OR DOUBLE? AOS CSPOS ;YES JRST ITER] HRL B,$ADR(LPSA) ;FIRST FIXUP HRRM B,$ADR(LPSA) ;SAVE ITS SACK INC TLNE B,-1 ;MIGHT BE UNUSED PUSHJ P,FIXOUT ;NO RELOC FOR FIXED UP VALUE TRNN TBITS,STRING!DBLPRC ;STRING OR DOUBLE? JRST ITER ;NO -- DONE WITH THIS AOS B,CSPOS ;BUMP STACK DISPL HLL B,$ADR(LPSA) ;SECOND WORD FIXUP CHAIN HRLM B,$ADR(LPSA) ;SAVE IT TLNE B,-1 ;USED? PUSHJ P,FIXOUT ;YES JRST ITER ;AT LAST ALCV: MOVEM LPSA,LSTSYM ;LAST SYMBOL AOS PNT2 ;INCREMENT COUNT. SKIPN FIRSYM MOVEM LPSA,FIRSYM ;RECORD FIRST SYMBOL ONCE!! TLNN FF,ALLOCT ;ACTUALLY ALLOCATE? JRST ITER ;NO -- LOOP HRLZ B,$ADR(LPSA) ;FIRST FIXUP HRR B,PCNT HRRM B,$ADR(LPSA) ;SAVE THE PCNT FOR SOUT TO FIND. TLNE B,-1 ;IN CASE A STRING WHICH ONLY USES SECOND WD. PUSHJ P,FBOUT ;OUTPUT THE FIXUP ; BUG TRAP -- $VAL SHOULD GENERALLY BE 0 THRU HERE SKIPE A,$VAL(LPSA) ;VALUE WORD TRNE TBITS,ITEM ;EXCEPT ITEMS......... JRST NVL ; IT IS ZERO TLNN TBITS,SBSCRP ;CAN BE NON-ZERO IF ARRAY ERR ,1 NVL: TLZ FF,RELOC TLNE TBITS,SBSCRP ;WANT RELOCATABLE IF ARRAY TLO FF,RELOC ; UNLESS IT IS ZERO PUSHJ P,CODOUT ;OUTPUT A WORD FOR IT! RGC < ;;%##% RHT MAKE TOPLEV PNTVAR GO ON RBLIST ; TLNN TBITS,SBSCRP ;OWN RPTR ARRAYS HANDLED ELSEWHERE ;; TLNN TBITS,OWN!BILTIN ;OWN?? ;;#VI# ! USED TO TEST FF FOR TOPLEV SKIPG LEVEL ;GTR 0 IF NOT AT TOP BLOCK TLNE TBITS,SBSCRP ;IF OWN OR TOPLEV, FORGET IT IF SBSCRP JRST NVL.1 ;NOPE ;;%##% ^ TRNE TBITS,PNTVAR ;RECORD PNTR?? TRNE TBITS,ITEM!ITMVAR ;WELL JRST NVL.1 ;NOPE ;;#TZ# -- ! USED TO BE HRLO. RHT 2-12-75 HRRO A,$ADR(LPSA) ;-1,,ADDRESS PUSH P,LPSA ;SAVE IT FROM HARM QPUSH (RBSTK) ;REMEMBER IT FOR LATER POP P,LPSA NVL.1: >;RGC TLZ FF,RELOC ;MAKE SURE IT'S OFF TRNN TBITS,STRING!DBLPRC ;DO WE WANT STILL ANOTHER WORD? JRST ITER ;NO -- LOOP HLLZ B,$ADR(LPSA) ;SECOND FIXUP HRR B,PCNT HRLM B,$ADR(LPSA) ;SAVE THIS FOR 2D SYMBOL IF ANY TLNE B,-1 ;IN CASE NOT USED. PUSHJ P,FBOUT ;OUTPUT FIXUP MOVEI A,0 PUSHJ P,CODOUT ;AND A WORD OF STORAGE. JRST ITER ;LOOP ;ROUTINE TO ALLOCATE SPACE FOR TEMP CELLS AND TO OUTPUT ;FIXUPS. TMPALO: SETZM PNT2 ;COUNT HRRZ LPSA,TTEMP JUMPE LPSA,CPOPJ RGC < TLNN FF,ALLOCT ;ONLY WORK HARD IF ACTUALLY ALLOCATING JRST TMPAL ;;#VV# 1 OF 2 A GREAT PILE OF CODE WAS WRONG HERE RCTMLP: HRRZS %TLINK(LPSA) ;LH 0 MEANS NOTHING SPECIAL HLRZ LPSA,%RVARB(LPSA); ZERO OUT WHOLE TTEMP CHAIN JUMPN LPSA,RCTMLP SKIPE LPSA,RCTEMP ;MARK ALL RECORD CORTMPS AS SPECIAL FELLOWS RCTM.1: HRROS LPSA,%TLINK(LPSA) ;MARK AS SPECIAL TRNE LPSA,-1 ; JRST RCTM.1 ;GO GET NEXT RCTM.2: HRRZ LPSA,TTEMP ;PUT LPSA BACK TO WHAT IT WAS IFN 0,< ;#VV# DELETION MOVEI PNT,0 ;USE THIS TO HOLD THE CHAIN RCTMLP: MOVE SBITS,$SBITS(LPSA) SETZM %TLINK(LPSA) ;SINCE NON-ZERO IS A MARK TLNN SBITS,CORTMP JRST NXRCTM TLNN SBITS,INDXED ;CHECK ALSO SUBFIELD INDXED CORTMP JRST RCTM.1 ;NOT ONE OF THOSE HRRZ B,$VAL2(LPSA) ;WELL ?? JUMPE B,NXRCTM ;NOT ONE OF THOSE JRST RCTM.2 ;YES IT IS RCTM.1: MOVE B,$TBITS(LPSA) TRNE B,PNTVAR ;A RECORD VBL TRNE B,ITEM!ITMVAR ;BUT NOT AN ITEMISH THING JRST NXRCTM ;NOPE RCTM.2: HRROM PNT,%TLINK(LPSA);MARK IT MOVE PNT,LPSA ;& REMEMBER CHAIN NXRCTM: HRRZ LPSA,%RVARB(LPSA) JUMPN LPSA,RCTMLP HRRZM PNT,RCTEMP ;REMEMBER WHICH TEMPS WERE RECORD VALUES HRRZ LPSA,TTEMP ;BACK IN BUSINESS >;IFN 0 ;; #VV# DELETION >;RGC ;;#YK# JFR 1-15-77 ALL THE DBLPRC STUFF TMPAL: MOVE SBITS,$SBITS(LPSA) ;S BITS. TLNN SBITS,CORTMP ;A CORE TEMP? JRST TMNXT ;NO MOVEM LPSA,LSTSYM ;SAVE SKIPN FIRSYM ;NO ARITH VARIABLES? MOVEM LPSA,FIRSYM ; THAT'S RIGHT, THIS TEMP IS FIRST MOVEI TBITS,INTEGR ;MIGHT BE INDXED STRING TEMP LEFT OVER, EXCH TBITS,$TBITS(LPSA) ;THIS IS EASIEST WAY TO AVOID CONFUSION ;(PRUP CHECKS STRING, DOES FXTWO, WE DON'T ; WANT THAT HERE) TLZ SBITS,INDXED!FIXARR ;DO SOME THINGS TO SBITS TOO TLZE SBITS,INAC!PTRAC!STTEMP ;ONLY REMAINING USE IS ERR ,1 ; FOR REC. PROC BLT CODE MOVEM SBITS,$SBITS(LPSA) ;(MORE HONESTY) TRNN TBITS,DBLPRC AOJA PNT2,.+2 ;ONLY SINGLE ADDI PNT2,2 ;DOUBLE SKIPN RECSW ;IF NOT RECURSIVE JRST ALCTMP ;THEY GO TO CORE AOS B,CSPOS ;BUMP THE STACK OFFSET TLNN FF,ALLOCT ;ACTUALLY ALLOCATE? AOJA B,[TRNE TBITS,DBLPRC ;NO MOVEM B,CSPOS ;BUT MAKE ROOM FOR DOUBLE JRST TMNXT] HRL B,$ADR(LPSA) ;PICK UP FIXUP CHAIN RGC < HRRM B,$ADR(LPSA) ;REMEMBER THE SURE ENOUGH VALUE >;RGC PUSHJ P,FIXOUT ;FIXUP TRNN TBITS,DBLPRC JRST TMNXT ;ONLY ONCE FOR SINGLES AOS B,CSPOS ;ANOTHER FOR DOUBLES HLL B,$ADR(LPSA) ;FIXUP FOR 2ND WORD TLNE B,-1 PUSHJ P,FIXOUT ;SOMEONE DID USE IT JRST TMNXT ALCTMP: TLNN FF,ALLOCT ;ACTUALLY ALLOCATE? JRST TMNXT ;NO HRR B,PCNT HRL B,$ADR(LPSA) RGC < HRRM B,$ADR(LPSA) ;REMEMBER THE SURE ENOUGH VALUE >;RGC PUSHJ P,FBOUT ;FIXUP ; PUT OUT A "TEMPXX" SYMBOL MOVE A,$PNAME(LPSA) ;ID NO FOR THIS TEMP IDIVI A,=10 ;TENS IN A, ONES IN B ADDI A,1 IMULI A,50 ;RADIX50 FOR TENS ADDI B,1 ;RADIX50 FOR ONES ADD A,[+(*50*50)] ADD A,B ;A HAS RADIX50 FOR "TEMPXX" HRRZ B,PCNT PUSHJ P,SCOUT ;WRITE A SYMBOL MOVEI A,0 PUSHJ P,CODOUT TRNN TBITS,DBLPRC JRST TMNXT HRRZ B,PCNT ;2ND WORD FOR DOUBLES HLL B,$ADR(LPSA) TLNE B,-1 PUSHJ P,FBOUT PUSHJ P,CODOUT ;;#YK# ^ TMNXT: HLRZ PNT,%RVARB(LPSA) ;GET NEXT ONE RGC < ;;#VV# ! USED TO SKIPN HERE SKIPL %TLINK(LPSA) ;ALSO DON'T KILL IF IT WAS A RECORD TEMP ;PDOUT WILL HACK THINGS >;RGC TLNN FF,ALLOCT JRST TMNN FREBLK ;RELEASE THE SYMBOL TABLE BLOCK TMNN: MOVE LPSA,PNT ;COPY IT BACK. JUMPN LPSA,TMPAL ;LOOP POPJ P, ^LNKMAK: ; PUT OUT STRING LINK BLOCK, IF NECESSARY SKIPN TEMP,SLOCALS JRST SETLNQ REN< SKIPE OVRSAI ;OVERLAY? PUSHJ P,LOSET ; YES, FORCE LINK AND DATA TO LOSEG MOVE TEMP,SLOCALS >;REN LSH TEMP,-1 ;NUMBER OF STRINGS HRLZ A,TEMP ;WORD WILL BE #STRINGS,,ADDR OF FIRST HRRZ LPSA,SLIMS ;SEMANTICS OF FIRST HRL C,$ADR(LPSA) ;ADDR OF FIRST TRO A,NOUSAC+USADDR PUSHJ P,EMITER ;PUT OUT DESCRIPTOR WORD EMIT () ;LINKAGE WORD -- PUT OUT ZERO MOVEI B,%STLNK ;STRING LINK. PUSHJ P,LNKOUT ;THEN A LINKAGE CALL TO LOADER REFERENCING IT REN< SKIPE OVRSAI ;OVERLAY? PUSHJ P,HISET ; YES, POSSIBLE BACK TO HISEG >;REN SETLNQ: SKIPN A,LLOCAL POPJ P, ;NO SETS TO LINK UP EITHER. REN< SKIPE OVRSAI ;OVERLAY? PUSHJ P,LOSET ; YES, FORCE LINK AND DATA TO LOSEG MOVE A,LLOCAL >;REN MOVNS A ;A WILL BE - # OF SETS,,ADR OF FIRST. HRRZ LPSA,LLIMS ;SEMANTICS OF FIRST ONE. HRL C,$ADR(LPSA) ;ADDRESS OF FIRST ONE. HRRI A,NOUSAC!USADDR PUSHJ P,EMITER ;PUT IT OUT. EMIT (NOADDR!NOUSAC) ;FOR THE LINK. MOVEI B,%SETLK ;SET LINK NUMBER PUSHJ P,LNKOUT REN< SKIPE OVRSAI ;OVERLAY? PUSHJ P,HISET ; YES, POSSIBLE BACK TO HISEG >;REN SNTP: POPJ P, COMMENT REQINI -- USER REQUIRED INITIALIZTIONS ZERODATA() INIPDP: 0 ;QSTACK POINTER FOR INITIALIZATIONS INIMAN: 0 ;FLAG IF INMAIN HAS BEEN CALLED ENDDATA DSCR REQINI,REQIN1,REQIN2 CAL PUSHJ PARM REQINI -- TAKES PROC SEMBLK FROM GENLEF+1 REQIN1 -- PROC SEMBLK IN PNT REQIN2 -- INITIALIZATION WORD IN A -- PHASE #,,LOC TO BE PUSHJ'ED TO RQINIX -- TAKES PROC SEMBLK IN GENLEF+3, PHASE IN GENLEF+1 REQIXX -- PROC SEMBLK IN PNT, PHASE IN SBITS2 DES PUSHES AN INITIALIZATION REQUEST ONTO QSTACK INIPDP. DONES WILL PUT OUT THE CONTENTS OF THIS QSTACK AS THE INITIALIZATION REQUEST BLOCK.  ;;%AM% (1 OF 2) ALLOW USER TO SPECIFY PHASES ^RQINIX: MOVE PNT2,GENLEF+1 ;PHASE NUMBER MOVE PNT,GENLEF+3 ;PROCEDURE MOVE TBITS2,$TBITS(PNT2); TDNN TBITS2,[XWD CNST,INTEGR]; MUST BE AN INTEGER JRST [ERR ,1 JRST REQIN1 ] SKIPGE SBITS2,$VAL(PNT2);GET THE VALUE JRST [ ERR ,1 MOVEI SBITS2,0 JRST REQIXX ] CAIL SBITS2,USRPHS ;MUST BE LESS JRST [ ERR ,1 MOVEI SBITS2,USRPHS-1 JRST REQIXX ] JRST REQIXX ^REQINI:MOVE PNT,GENLEF+1 ;GET PROCEDURE ^REQIN1:MOVEI SBITS2,1 ;THE LOWEST PHASE NUMBER+1 ^REQIXX:HLRZ PNT2,%TLINK(PNT);2ND BLOCK ;;%AM% ;;#YS# 2! JFR 2-2-77 TELL LUSER HE (PROBABLY) WILL AT RUNTIME SKIPN $VAL(PNT2) ;TOP LEVEL AT PRDEC? ERR ,1 ;;#QK# RHT OWN PROCS ARE SPECIAL PUSHJ P,GETAD TLNE TBITS,OWN ;RUNTIME ROUTINE?? JRST [ MOVE A,$ACNO(PNT) ;BYTE WORD TLNE A,770000 ;ZERO BYTE HERE MEANS NO PARAMS ERR ,1 JRST EXTCSE ;TREAT AS AN EXTERNAL ] ;;#QK# ;; JFR 8-4-75 SKIPE OVRSAI ERR ,1 ;;^ ;;#JH# ! RHT 9-29-72 TYPO ERROR HRLZI A,1 ; CAME A,$NPRMS(PNT2) ;ANY PAPAMS ERR ,1 TLNN TBITS,FORWRD!EXTRNL ;IF ONE OF THESE, HARDER JRST ESYCS ;;#QK# ! EXTCSE: HRRZ C,PCNT HRLI C,2(C) EMIT ;JRST .+2 HRRZ A,PCNT HRLI A,400000 QPUSH (INIPDP) ;REMEMBER THIS SPOT EMIT ;CALL THE PROCEDURE POPJ P, ESYCS: HRRZ A,$ADR(PNT) ;;%AM% (2 OF 2) ! HRLI A,400000(SBITS2) ;PHASE NO REQIN2: QPUSH (INIPDP) ;REMEMBER THE ROUTINE ADDRESS POPJ P, COMMENT  INMAIN - REQUEST INITIALIZATION FOR MAINPR IF NOT ALREADY DONE  ^INMAIN: SKIPE INIMAN ;ALREADY REQUESTED? POPJ P, ;YES SETOM INIMAN ;REQUESTED NOW HRRZ C,PCNT HRLI C,2(C) ;FOR JRST .+2 EMIT HRL C,PCNT EXCH C,LIBTAB+RMAINPR ;LIBRARY ENTRY FOR MAINPR EMIT HRR A,PCNT SUBI A,1 HRLI A,1 ;PHASE 1 JRST REQIN2 SUBTTL DONES -- Storage Allocation Routines -- end of program DSCR DONES PRO DONES DES This is the DONE code. It takes care of any allocation that must be left until the end, allocates constants,etc. The order of operations is: 1. Allocate space for any remaining variables, temps, etc. 1aa. Put out block of counters if /K switch is specified. 1aaa. Put out initialization link. 1a. Put out LEAP printnames if any. 2. Allocate space for constants,string constants, and address constants. 3. Output external requests for built-in procedures. 4. Output external requests for run-time (XCALL) routines. 5. Put out rqsts for other programs to be loaded, libraries to be searched 6. Finish all binary output, and write an end block. 7. Put out the space allocation information block. This is examined at run time to know how much space need be allocated for various purposes (strings, leap, array push-down, etc.). SEE ALOT for variable-allocation code  ;1 ^DONES: PUSHJ P,ALLSTO ;STORE EVERYONE ;;%BT% RHT MAKE PD LOOK BETTER MOVE LPSA,TPROC ;GET CORRECT LOC FOR JRST EXIT MOVEI TEMP,3 ;PCNT AT START OF PROC HRRM TEMP,$ADR(LPSA) ;SO PD IS CORRECT MOVE TEMP,PCNT HRRM TEMP,$ACNO(LPSA) ;;%BT% ^ ;;%AL% RHT ! TREAT 12 RIGHT EMIT ;;%DN% JFR 7-4-76 HRLI C,-3 PUSHJ P,EPADJ ;ADJUST P STACK ;;%DN% ^ EMIT () ;RETURN ;;#XP# JFR 10-17-76 SKIPE LEAPIS ;IF ANY DECLARED ITEMS, ETC. THEN MUST LOAD LEAP SKIPE LIBTAB+RLEAP JRST DONES1 ;NO DECLARATIONS, OR ALREADY CALLED XCALL ;A DUMMY CALL TO FORCE LOADING DONES1: ;;#XP# ^ TLO FF,ALLOCT ;THIS TIME WE DO THINGS RIGHT OFF PUSHJ P,ALOT SKIPE ADRTAB ;MUST BE EXHAUSTED AT THIS POINT ERR ,1 ;;%BV% -- BY NOW HAVE PUT OUT PD, SO PDA HAS CORRECT PCNT MOVE TEMP,TPROC ; MOVE TEMP,$VAL(TEMP) ;GET PD SEMBLK MOVE TEMP,$ADR(TEMP) ;LOCN OF PDA HRRM TEMP,OBPDA ;PUT IT AWAY ;;%BV% ^ BAIL< SKIPG BAILON ;BAILING? JRST NBAI01 ;NO PUSHJ P,BCROUT ;LAST COORDINATE SETZ SBITS, PUSHJ P,VALOUT ;FLAG END OF TABLE HRROI SBITS,-1 PUSHJ P,VALOUT ;FLAG END OF FILE TENX< PUSHJ P,VALOU1 ;DUMP LAST BUFFER >;TENX NOTENX< OUTPUT SM1, ;DUMP LAST BUFFER >;NOTENX NBAI01: >;BAIL REN < PUSHJ P,LOSET ;DATA TO DATA SEGMENT >;REN COMMENT  If the /K switch was specified, we are now ready to alocate space for the counters and put out the small data block used by the runtime routines K.ZERO and K.OUT. The block is linked to other such blocks via the loader LINK feature, using link number 5. There will be multiple counter blocks only in the case of multiple compilations. If there are no counters inserted, then nothing is put out. The symbolic name .KOUNT is given to the location of the first counter. The routine K.OUT needs a file name to write the counters out to after execution. The filename is set to the name of the listing file. (they will have different extensions.) The generated code will look as follows: -------------------------- | SIXBIT /FILNAM/ | -------------------------- | LINK to other blocks | -------------------------- | IOWD 4,.-2 | -------------------------- | IOWD n,.KOUNT | -------------------------- | 0 | -------------------------- .KOUNT: | 1st counter | -------------------------- | . . . | | . . . | -------------------------- | nth counter | --------------------------  SKIPE KOUNT ;ARE WE INSERTING COUNTERS SKIPN KCOUNT ;AND ARE THERE ANY JRST NOK3 ;NO ON ONE OF THE ABOVE NOTENX < MOVEI TBITS2,LSTCDB ;GET FILE NAME MOVE A,CFIL(TBITS2) >;NOTENX TENX <;WE WANT THE SIXBIT NAME OF THE LST FILE IN AC A ZERODATA LISFLN: BLOCK 11 ENDDATA PUSH P,B PUSH P,C PUSH P,D HRROI A,LISFLN HRRZ B,LISJFN ;SET UP IN CC MOVSI C,002000 ;PRINT NAME ONLY JSYS JFNS ;GET THE NAME MOVEI C,6 SETZ A, ;ACCUMULATE SIXBIT HERE MOVE B,[POINT 7,LISFLN,-1] SIXLUP: ILDB D,B ;GET A BYTE SKIPE D SUBI D,40 ;CONVERT TO SIXBIT LSH A,=6 ;MOVE OVER ADD A,D ;ADD IN SOJG C,SIXLUP POP P,D POP P,C POP P,B >;TENX TLZ FF,RELOC ;DON'T RELOCATE IT PUSHJ P,CODOUT ;WRITE IT MOVEI A,0 PUSHJ P,CODOUT ;PUT OUT A ZERO WORD MOVEI B,%KTLNK ;LINK IT INTO CHAIN %KTLNK PUSHJ P,LNKOUT MOVE C,PCNT MOVSI C,-3(C) EMIT () ;IOWD 4,.-2 MOVN A,KCOUNT HRLZ A,A ;-COUNT HRR A,PCNT ;.KOUNT-2 ADDI A,1 ; IOWD N,.KOUNT TLO FF,RELOC ;RELOC PLEASE PUSHJ P,CODOUT MOVEI A,0 ;ANOTHER 0 PUSHJ P,CODOUT PUSHJ P,FRBT ;FORCE OUT CODE BLOCK HRRZ B,PCNT MOVE A,[RADIX50 10,.KOUNT] ;DEFINE SYMBOLIC NAME PUSHJ P,SCOUT ;FOR THE COUNTERS MOVE A,KCOUNT ADDM A,PCNT ;LEAVE SPACE FOR THEM COMMENT  Now we fix up all counters addresses in the AOS instructions that have already been output.  MOVE B,PCNT ;POINT JUST PAST THE COUNTERS ISK1: MOVEI B,-1(B) ;MOVE POINTER BACK ONE QPOP (KPDP) ;GET ADDR OF AN AOS JUMPL A,NOK3 ;THAT'S ALL HRL B,A ;PREPARE B FOR FBOUT PUSHJ P,FBOUT ;FIXUP JRST ISK1 ;ONE MORE TIME NOK3: BAIL< ;PUT OUT FILE NAME AND RELOCATION CONSTS. SKIPG BAILON JRST NBAI02 SETZ A, TLZ FF,RELOC ;NO RELOC PUSHJ P,CODOUT ;PUT OUT ZERO WORD MOVEI B,%BALNK PUSHJ P,LNKOUT ;LINK IT TO BAIL CHAIN TLO FF,RELOC ;RELOC ;;#%%# BY JFR 11-13-74 MAKE THIS XWD 1,1 IN ALL CASES MOVE A,[XWD 1,1] ; A RELOCATABLE 1 REN< SKIPE HISW ;TWO SEG PROG? HRLI A,400001 ;YES ;;#%%# ^ >;REN PUSHJ P,CODLRL ;RELOCATE BOTH HALVES TLZ FF,RELOC ;NO RELOC NOTENX< ;;%DO% JFR 7-5-76 USED TO JUST GIVE FILE NAME ;;=I10= MOVEI A,4+SFDLVL ;FILE,EXT,PPN,DEV PUSHJ P,CODOUT MOVEI TBITS2,SM1CDB MOVE A,CFIL(TBITS2) ;NAME PUSHJ P,CODOUT MOVE A,CEXT(TBITS2) PUSHJ P,CODOUT MOVE A,CPPN(TBITS2) SFDS< JUMPE A,.+3 ;IF ZERO, IT'S OK TLNN A,-1 ;OR IF LH NEQ 0 MOVE A,CPATH+2(TBITS2) ;IF PTR, HERE IS REAL PPN PUSHJ P,CODOUT MOVSI B,-SFDLVL ;NOW FOR SFD'S HRRI B,CPATH+3(TBITS2) ;FIRST SFD MOVE A,(B) ;GET THE SFD PUSHJ P,CODOUT AOBJN B,.-2 ;AND REST >;SFDS NOSFDS< PUSHJ P,CODOUT >;NOSFDS MOVE A,CDEV(TBITS2) PUSHJ P,CODOUT ;;%DO% ^ >;NOTENX TENX< ;[clh] put string on stack rather than RACS. RACS is in the user ;[clh] table, and so must be relocated by GOGTAB. Not doing so puts ;[clh] the string starting at location 133 absolute, and garbages ;[clh] lots of crucial variables. HRROI A,1(P) ;[clh] PUT STRING ON THE STACK ADD P,[XWD 33,33] ;[clh] TLNN P,400000 ;[clh] ERR ,1 ;[clh] ;[clh] MOVE A,[POINT 7,RACS] ;NICE BIG TEMP AREA MOVE B,SM1JFN MOVE C,[XWD 111100,1] ;[clh] dev:name.ext JSYS JFNS ;JFN TO STRING ;;%##% JFR 31-MAY-75 CLEAN UP TRAILING GRABAGE ON FILE NAME MOVE B,A ;UPDATED BYTE POINTER SETZ C, IDPB C,B IDPB C,B IDPB C,B IDPB C,B ;;%##% ^ HRRZ A,A SUBI A,1-33(P) ;[clh] ;[clh] SUBI A,RACS ADDI A,1 ;# WORDS IN NAME PUSHJ P,CODOUT MOVN B,A HRLZ B,B ;AOBJN POINTER HRRI B,1-33(P) ;[clh] MOVE A,(B) ;[clh] ;[clh] MOVE A,RACS(B) PUSHJ P,CODOUT AOBJN B,.-2 SUB P,[XWD 33,33] ;[clh] >;TENX NBAI02: >;BAIL ; here put the initialization requests. IFN 0,< ;ALL THIS IS PROCEDURIZED NOW SKIPN INIPDP ;ANY ON THE QSTACK? JRST INI.DN ;NO MOVEI A,0 ;FOR THE LINK TLZ FF,RELOC PUSHJ P,CODOUT MOVEI B,%INLNK PUSHJ P,LNKOUT ;PUT OUT THE LINK TLO FF,RELOC QBEGIN (INIPDP) ;GET READY TO TAKE SOME OUT NX.INI: QTAKE (INIPDP) ;TAKE NEXT ENTRY JRST INI.D1 ;DONE PUSHJ P,CODOUT ;PUT OUT THE REQUEST JRST NX.INI INI.D1: MOVEI A,0 TLZ FF,RELOC PUSHJ P,CODOUT INI.DN: >;IFN 0 PUSH P,INIPDP ;INITIALIZATIONS MOVEI B,%INLNK ; PUSHJ P,QSTKOU QFLUSH (INIPDP) ;FLUSH THE QSTACK RGC < PUSH P,RBSTK ;RECORD BLOCKS MOVEI B,%RBLNK PUSHJ P,QSTKOU QFLUSH (RBSTK) >;RGC REN < PUSHJ P,HISET ;BACK TO UPPER SEGMENT TO >;REN PUSHJ P,LNKMAK ;MAKE LINKAGE BLOCK ;;JFR 8-3-75 THIS IS USED AT INITIALIZATION TIME, SO MUST GO IN LOW ;;SEGMENT IF OVERLAYS SKIPE OVRSAI PUSHJ P,LOSET ;;^ ;1A SKIPE LEAPIS ;ANY LEAP ASKED FOR ;; %AG% GITEMNO NOW CONTAINS THE LEAPIS FLAG HRROS GITEMNO ;TELL RUNTIMS YES ;; \ur#7\ require overlap!ok MOVE A,OKLPOV HLLZM A,TINIT ;FLAG TO SUPPRESS WARNING ;; \ur#7 SKIPN ITMSTK ;ANY DECLARED ITEMS? JRST CONQN ;NONE MOVE A,PCNT ;GET PROG. CNTR ;;\ ur#7\ HRRM A,TINIT ; RH (used to be movem) ;;\ur#7\ MOVE A,ITMCNT ;NUMBER OF DECLARED ITEMS(INCLUDES GLOBALS) TLZ FF,RELOC PUSHJ P,CODOUT ;PUT IT OUT MOVE B,ITMBEG ;START OF ITEM QSTACK LPITMT: QTAKE (ITMSTK) ;GET ITEM,TYPE JRST PNMOUT ;THROUGH, NO MORE ITEMS PUSHJ P,CODOUT JRST LPITMT ;LOOP PNMOUT: MOVE A,PCNT MOVEM A,PINIT TLZ FF,RELOC SOS A,PNMSW ;NUMBER OF NAMES. PUSHJ P,CODOUT ;PUT OUT SOME STUFF. SKIPN PNMSW JRST CONQN ;NO PNAMES -- SE ABOUT CONSTANTS. MOVE B,PNBEG ;THE QTAKE POINTER ITM1: QTAKE (PNLST) JRST ITM2 ;ALL DONE. MOVE PNT,A ;FOR EMITTER HRRI A,NOUSAC PUSHJ P,EMITER ; #CHARS,,POINTER TO BYTE POINTER. JRST ITM1 ITM2: CONQN: SKIPE OVRSAI PUSHJ P,HISET ;BACK TO HIGH SEGMENT, POSSIBLY ;2 TLZ FF,RELOC HRRZ LPSA,CONINT ;VARB-LIKE RING OF CONSTANTS. JUMPE LPSA,STRGO OPTSYM %$LIT ;BEGIN LITERALS REN < MOVSI D,RECURS ;GET REAL LIVE CONSTANTS FIRST PUSHJ P,INTLOP OPTSYM %.LIT ;END LITERALS PUSHJ P,LOSET ;SWITCH TO LOWER SEGMENT IF HISW HRRZ LPSA,CONINT ;NOW GET CONSTANTS WHICH WERE JUMPE LPSA,STRG1 ; (IF ANY LEFT) OPTSYM %$RLIT ;BEGIN REFERENCE LITERALS MOVEI D,0 ;UNIQUELY CREATED AS REFERENCE PUSH P,INTRET ; PARAMS ; PUSHJ P,INTLOP >;REN INTLOP: REN < TDNE D,$TBITS(LPSA) ;THIS TIME? JRST GOLEFT ; NO, WAIT FOR LOWER SEGMENT >;REN HRLZ B,$ADR(LPSA) ;FIXUP JUMPE B,NOINT1 ;NOT USED HRR B,PCNT PUSHJ P,FBOUT MOVE A,$VAL(LPSA) ;VALUE PUSHJ P,CODOUT ;A WORD FOR IT. NOINT1: HLLZ B,$ADR(LPSA) ;2ND FIXUP WORD FOR DOUBLE CONSTANTS JUMPE B,NOINT2 ;NOT USED HRR B,PCNT PUSHJ P,FBOUT NOINT2: MOVE A,$VAL2(LPSA) MOVE TEMP,$TBITS(LPSA) TRNN TEMP,ITEM!ITMVAR TRNN TEMP,DBLPRC JRST .+2 PUSHJ P,CODOUT NOINT: REN < PUSHJ P,URGCNM ;REMOVE FROM RING GOLEFT: >;REN LEFT ,%RVARB,INTRET JRST INTLOP ;LOOP UNTIL DONE. INTRET: REN < POPJ P,.+1 OPTSYM %.RLIT ;END REFERENCE LITERALS ;; JFR 8-5-75 STRINGS ARE "REFERENCE" OBJECTS, MUST GO LOW FOR OVERLAYS STRG1: SKIPN OVRSAI PUSHJ P,HISET ;BACK TO UPPER IF NOT OVERLAYS ;;^ >;REN STRGO: OPTSYM %$STRC ;BEGIN STRING CONSTANTS HRRZ LPSA,CONSTR ;STRING CONSTANT RING. JUMPE LPSA,BILGO STRLOP: MOVS B,$ADR(LPSA) ;FIXUPS JUMPE B,[SKIPN B,$VAL(LPSA) ;SEE IF STORED IN PRE-LOADED ARRAY JRST NOSTR ;NOT USED AT ALL. HRR B,PCNT ;NOW XWD FIXUP,,PCNT PUSHJ P,FBOUT ;EMIT IT. JRST PUTIT] HRLZ B,$ADR(LPSA) ;FIXUP FOR FIRST WORD. JUMPE B,.+3 HRR B,PCNT PUSHJ P,FBOUT HRRZ A,$PNAME(LPSA) ;COUNT OF CHARACTERS. PUSHJ P,CODOUT HLLZ B,$ADR(LPSA) ;FIXUP FOR SECOND WORD. JUMPE B,.+3 HRR B,PCNT PUSHJ P,FBOUT ;OUTPUT THE FIXUP. JUMPE A,NOSTR ;IN CASE NULL FLIES BY. HRLI A,() ;BYTE POINTER HRR A,PCNT ADDI A,1 ;POINT TO .+1 SKIPN B,$VAL(LPSA) ;FIXUP FROM PRE-LOADED ARRAY IF ANY. JRST .+3 HRR B,A ;THE PCNT FOR ASCII PUSHJ P,FBOUT ;GO GUYS. TLO FF,RELOC PUSHJ P,CODOUT TLZ FF,RELOC PUTIT: HRRZ B,$PNAME(LPSA) ;COUNT AGAIN. ADDI B,4 IDIVI B,5 ;B HAS NUMBER OF WORDS. HRRZ C,$PNAME+1(LPSA) ;POINTER TO FIRST WORD. STLL: MOVE A,(C) PUSHJ P,CODOUT AOS C SOJG B,STLL NOSTR: LEFT ,%RVARB,BILGO JRST STRLOP ;LOOP FOR ALL STRINGS. ;3 BILGO: OPTSYM %.STRC ;END STRING CONSTANTS ;;8-5-75 BACK TO UPPER PUSHJ P,HISET ;;^ MOVE LPSA,VARB CAIE LPSA,RESYM ;IT SHOULD BE HERE ERR BILOP: HRRZ B,$ADR(LPSA) ;FIXUP JUMPE B,BILR TLNE FF,CREFSW ;CREFFING?? PUSHJ P,CREFDEF ;DEFINE THIS SYMBOL. PUSHJ P,SOUT ;GENERATE EXTERNAL REQUEST BILR: LEFT ,%RVARB,LIBGO JRST BILOP ;LOOP UNTIL DONE ;4 ; IF GAG, WILL GET ADDRESSES DIRECTLY (MOVEI) LIBGO: MOVEI C,0 LIBLOP: SKIPN B,LIBTAB(C) ;FIXUP FOR THIS FCN. JRST NONT YESLIB: MOVSS B MOVE A,LIBNAM(C) ;RADIX50 FOR THIS FCN. PUSHJ P,SCOUT ;GENERATE THE REQUEST. NONT: AOS C CAIE C,LIBNUM JRST LIBLOP ;LOOP UNTIL DONE. ;5 GSYSIN ;[clh] get sysind if Tenex HRROI TEMP,SALIB+1(SYSIND) ;[clh] FAKE STRING DESCRIPTOR FOR SAIL LIBRARY REN < SKIPE HISW ;WANT RE-ENTRANT LIBRARY? HRROI TEMP,SALIBH+1(SYSIND) ;[clh] YES >;REN POP TEMP,PNAME+1 POP TEMP,PNAME MOVEI B,LBTAB ;PUT OUT LIBRARY SEARCH PUSHJ P,PRGOUT ; REQUEST BAIL< ;;#%%# BY JFR 2-1-75 ADD A BIT IN BAILON TO CONTROL THIS MOVE TEMP,BAILON JUMPE TEMP,NBAI08 ;IF NO BAIL AT ALL TRNE TEMP,BBUSR ;DOES USER HAVE HIS OWN? JRST NBAI08 ;YES ;;#%%# ^ GSYSIN ;[clh] load SYSIND HRROI TEMP,BAIREL+1(SYSIND) ;REQUEST SYS:BAIL.REL LOAD!MODULE POP TEMP,PNAME+1 POP TEMP,PNAME MOVEI B,PRGTAB PUSHJ P,PRGOUT NBAI08: ;;%##% JFR 2-16-75 FOR KNOWLEDGE OF SAIL RUNTIMES MOVE TEMP,BAILON JUMPE TEMP,NBAI09 ;IF NO BAIL AT ALL TRNN TEMP,BBPDS ;DOES USER WANT THIS? JRST NBAI09 ;NO GSYSIN ;[clh] load SYSIND HRROI TEMP,BAIPD+1(SYSIND) ;YES POP TEMP,PNAME+1 POP TEMP,PNAME MOVEI B,PRGTAB PUSHJ P,PRGOUT NBAI09: ;;%##% ^ >;BAIL ;6 PUSHJ P,FRBT ;FORCE BINARY. MOVEI B,FXTAB PUSHJ P,GBOUT ;AND FIXUPS. MOVEI B,SMTAB PUSHJ P,GBOUT ;AND SYMBOLS. MOVEI B,PRGTAB PUSHJ P,GBOUT ;AND PROGRAM/LIBRARY REQUESTS MOVEI B,LBTAB PUSHJ P,GBOUT ;;%BR% ;NOW SAVE THE COMPILER VERSION NUMBER, SO WE CAN CHECK AT STARTUP MOVE A,[.VERSION] MOVEM A,COMVER ;;%BR% ^ ;7 ;NOW OUTPUT THE SPACE ALLOCATION BLOCK. REN< SKIPE OVRSAI ;OVERLAY? PUSHJ P,LOSET ; YES, FORCE LINK AND DATA TO LOSEG >;REN MOVE A,PCNT MOVEM A,SPCPC ;PCNT FOR SPACE BLOCK. MOVEM A,SLNKWD ;AND FOR LINK WORD. HRRZ TEMP,SPCTBL ;NUMBER OF WORDS OF DATA ADDI A,(TEMP) ;NUMBER OF WORDS IN OBJECT MODULE MOVEM A,PCNT MOVEI B,SPCTBL ;SPACE TABLE ;;#TR# (2 OF 3) USE BLOCK COUNT ; AOS TEMP,SPCTBL ;ONE MORE (A ZERO) ; MOVEI A,=18 ; CAIG A,(TEMP) ; HRRM A,SPCTBL ;MAKE SURE NO OVERFLOW HAPPENS AOS SPCTBL ;ONE MORE (FOR THE ZERO) ;;#TR# ^ PUSHJ P,GBOUT MOVEI TEMP,%SPLNK ;SPACE BLOCK IS TYPE %SPLNK MOVEM TEMP,LNKNM MOVE B,SDSCRP ;LINK BLOCK PUSHJ P,GBOUT ;AND LINK (LINK NUMBER 2) MOVE B,EBDSC ;ASSUME SHOULD WRITE START ADDR, ETC. TLNN FF,MAINPG ;A STARTING ADDRESS? MOVE B,EBDSC1 ;NO, NO START ADDR, NO INIT CODE FIXUPS REN < PUSHJ P,HISET ;BE SURE PCNT IS IN UPPER SEGMENT MOVE A,[XWD 5,2] ;ASSUME TWOSEG END BLOCK MOVE TEMP,[IORM A,STRDDR] ;PUT CONSTANT SYMS INTO HI SEG SKIPE HISW ;RIGHT? JRST TSEND ;RIGHT MOVE TEMP,[ANDCAM A,STRDDR] ;PUT CONSTANT SYMS INTO LOW SEG MOVE A,[XWD 5,1] ;ONESEG END BLOCK SUB B,[XWD 1,0] ;ONE FEWER WORDS TO WRITE TSEND: MOVEM A,PRGBRK-2 ;TO CODE WORD OF LOADER BLOCK MOVEI A,400000 ;SEGMENT CONTROL BIT XCT TEMP ;STARTING ADDRESS INTO RIGHT SGMNT HRRI TEMP,CONSYM+1 ;NOW XCT TEMP ; PUT S., RPGSW, SAILOR REQUESTS ADDI TEMP,2 ; INTO PROPER SEGMENT (SEE TOTAL, XCT TEMP ; UNDER LOADER OUTPUT BLOCKS ADDI TEMP,4 ; -- END BLOCKS SECTION XCT TEMP MOVE A,HCNT ;YES, GET CODE COUNT MOVEM A,PRGBRK+1 ;LOW SEG BREAK IF TWO SEGMENTS >;REN MOVE A,PCNT ;ONLY OR HIGH SEG BREAK MOVEM A,PRGBRK PUSHJ P,GBOUT ;WRITE THE END BLOCKS. POPJ P, ;ALL DONES ;ROUTINE TO PUT OUT A QSTACK FULL OF WORDS (ALL RELOC), FOLLOWED BY A ZERO ; AND PRECEDED BY A LINK WORD FOR SOME LOADER LINK ; PARAMS: QPDP IN (P), LINK NUMBER IN B ; SID: CLOBBERS B,A,LPSA,TEMP,FF(RELOC) QSTKOU: SKIPN -1(P) ;QPDP EMPTY JRST QS.XIT ; REN< PUSH P,B SKIPE OVRSAI ;OVERLAY? PUSHJ P,LOSET ; YES, FORCE LINK AND DATA TO LOWSEG POP P,B >;REN MOVEI A,0 ;NO, PUT OUT A WORD FOR THE LINK TLZ FF,RELOC ;LIKE SO PUSHJ P,CODOUT ; PUSHJ P,LNKOUT ;LINK GOES OUT TLO FF,RELOC ;FOR ALL THE ADDRESSES QBEGIN (<-1(P)>) ;SETS UP ACB QS.OU1: QTAKE (<-1(P)>) ; JRST QS.OU2 ;ALL DONE PUSHJ P,CODOUT ;PUT OUT WORD JRST QS.OU1 ;ITERATE QS.OU2: MOVEI A,0 ; TLZ FF,RELOC PUSHJ P,CODOUT REN< SKIPE OVRSAI ;OVERLAY? PUSHJ P,HISET ; YES, POSSIBLE FORCE BACK TO HISEG >;REN QS.XIT: SUB P,X22 JRST @2(P) COMMENT MEMORY and LOCATION EXECS, ALSO UINCLL ^^ZBITS: SETZM BITS POPJ P, ^^MEMI: SKIPA TBITS,[INTEGR] ^^MEMS: MOVE TBITS,BITS TDNE TBITS,[XWD PROCED!SBSCRP,STRING];ILLEGAL TYPES ERR ,1 PUSHJ P,TYPDEC ;GET PARSE TOKEN MOVEM A,PARRIG ;PUT IT AWAY MOVE PNT,GENLEF+1 ;THE EXPRESSION GUY MOVE SBITS,$SBITS(PNT) ;SEMANTICS OF THE EXPRN HRRZ TEMP,$TBITS(PNT) ;IT BETTER BE INTEGER ;;#JY# RHT (11-2-72) ! TURN OFF SHORT TRZ TEMP,SHORT ;TTURN OFF SHORT TLNN SBITS,NEGAT ;AND NOT NEGATIVE CAIE TEMP,INTEGR JRST COERCI TLNE SBITS,INAC ;LOADED? JRST ITSINA ;YES TLNE SBITS,ARTEMP ;IF NOT A TEMP ;;#YH# ! JFR 1-11-77 NEED TO LOAD FIXARR, TOO. MEMORY[B[0]] TLNE SBITS,INDXED!FIXARR ;OR INDEXED TEMP JRST LODIT ;THEN LOAD IT TLO SBITS,INDXED ;MAKE INDEXED TEMP MOVEM SBITS,$SBITS(PNT) ; MOVEM TBITS,$TBITS(PNT) ; SETZM $VAL(PNT) ; POPJ P, LODIT: PUSHJ P,GETAN0 ;GET AN AC EMIT ;LOAD IT MAKTMP: HRLZI SBITS,PTRAC!INDXED PUSHJ P,GETTEM HRRZM LPSA,ACKTAB(D) ;REMEMBER IT HRRM D,$ACNO(LPSA) MOVEM LPSA,GENRIG POPJ P, ITSINA: HRRZ D,$ACNO(PNT) ;GET AC # PUSHJ P,REMOPA ;IF TEMP, REMOP IT ;;#JV# ! (10-20-72) RHT CANNOT USE AC0 JUMPE D,LODIT ; TLZ SBITS,INAC ; MOVEM SBITS,$SBITS(PNT) ;THIS WONT BE INAC ANY MORE JRST MAKTMP ;NICE, NEW TEMP COERCI: PUSH P,TBITS ; MOVEI B,INTEGR ;;#TX# ! (2-7-75) RHT MAKE SURE GET INDX AC GENMOV (GET,POSIT!INSIST!GETD!INDX) PUSHJ P,REMOP ;DONE OLD THING POP P,TBITS JRST MAKTMP ;NEW TEMP ^^LOCN: MOVE PNT,GENLEF+1 ; PUSHJ P,GETAD IFN 0,< ;DIDNT WORK JFR 10-11-75 ;;#VJ JFR 10-11-75 DONT BOTHER WITH TYPE STUFF FOR PROCEDURES TRNE TBITS,PROCED JRST [PUSHJ P,GETAN0 EMIT (MOVEI JSFIX) JRST LOCN.1] ;;#VJ ^ >;IFN 0 TLNN SBITS,PTRAC ;IF PTRAC THEN LEAVE ALONE PUSHJ P,INCOR ;GET THE THING TO CORE GENMOV (GET,ADDR) ;ADDRESS OF THIS PUSHJ P,REMOP LOCN.1: MOVEI TBITS,INTEGR HRLZI SBITS,INAC GENMOV (MARK,0) MOVEM PNT,GENRIG PUSHJ P,TYPDEC MOVEM A,PARRIG POPJ P, ^UINCLL: PUSHJ P,ALLSTO ;FLUSH ACS XCALL (.UINITS) ;EMIT CALL TO USER INITIALIZATIONS POPJ P, ;; MINOR RECORD EXECS REC < ZERODATA (RECORD VARIABLES) ^QRCTYP: 0 ;HOLDS THE RECORD CLASS FOR THE RECORDPOINTER ^URCIPR: 0 ;NAME OF HANDLER PROCEDURE FOR A RECORD ^RCLASS: 0 ;RECORD CLASS HOLDER FOR MARK. MARK ALWAYS COPIES THIS ;INTO THE LEFT HALF OF $ACNO OF ANY TEMP IT MARKS ^CURRCC: 0 ;NAME OF CURRENT RECORD CLASS BEING DEFINED ^RCLPDL: 0 ;RECORD CLASS PDL ^NLRCBK: 0 ;HOLDS SEMBLK FOR NULL RECORD ^RCTEMP: 0 ; LIST OF CURRENTLY AVAILABLE RECORD TEMPS ^RBSTK: 0 ; QPDP FOR -CNT,,ADR WORDS ;;#%%# ! BY JFR 2-1-75 TO HELP BAIL RECOGNIZE THESE GUYS ^RCDFLG: 0 ; NEQ 0 DURING RECORD CLASS DECLARATION PROCESSING ENDDATA ;NEW EXEC ROUTINES: ^NLLREC: ;CREATES A NULL RECORD SKIPE PNT,NLRCBK ;HAVE ONE? JRST GOTNRC ;YEP, USE IT SETZM SCNVAL ;NO MUST MAKE ONE MOVE TBITS,[XWD CNST,PNTVAR] MOVEM TBITS,BITS HRROS RCLASS ; PUSHJ P,CONINS; HRROS $ACNO(PNT) ;THE UNIVERSAL CLASS MOVEM PNT,NLRCBK GOTNRC: MOVEM PNT,GENRIG POPJ P, ^RCCREM: MOVE PNT,GENRIG ;CALLED AFTER PRDEC MOVEM PNT,CURRCC ;;#%%# ! JFR 2-1-75 SETZM RCDFLG POPJ P, ^SETIRP: ;REMEMBER THAT THIS IS A RECORD POINTER MOVEI A,PNTVAR ORM A,BITS POPJ P, ^TWDIRC: ;REMEMBER RECORD CLASS CAIE B,1 ;ANYCLASS? SKIPA PNT2,GENLEF HRRZI PNT2,-1 CAIN B,2 ;AN IPR? CAMN PNT2,CURRCC ;YES, IS IT ONLY TEMPORARILY THAT SKIPA ERR ,1 SKIPE PNT,QRCTYP ; JRST MULRCC ;A MULTIPLE RECORD CLASS MOVEM PNT2,QRCTYP POPJ P, MULRCC: CAIN PNT,-1 ;THE SPECIAL "ANYTHING" FLAG SKIPA TBITS,[PNTVAR!SHORT]; SO THAT WILL GET SOME MORE PUSHJ P,GETAD ;IS THE THING THERE ALREADY A CLASS? TRNN TBITS,LSTBIT ;THIS IS THE GIVEAWAY JRST [ GETBLK ;GET A BLOCK FOR THE PURPOSE TRO TBITS,LSTBIT ;FLAG IT MOVEM TBITS,$TBITS(LPSA) MOVEI TEMP,1 MOVEM TEMP,$PNAME(LPSA) MOVE PNT,LPSA ; SAVE IT EXCH LPSA,QRCTYP ; NOW LPSA IS THE THING USED TO HAVE HRLI TEMP,() ; HRRI TEMP,$ADR(PNT) ;A SURE ENOUGH BYTE POINTER MOVEM TEMP,$PNAME+1(PNT) ; IDPB LPSA,TEMP ;REMEMBER OLD QRCTYP MOVEM TEMP,$SBITS(PNT) ;AND NEW VERSION OF BYTE POINTER QPUSH (RCLPDL,PNT) ;SAVE THIS SO WE CAN KILL IT OFF JRST .+1 ] AOS TEMP,$PNAME(PNT) ;ONE MORE CAILE TEMP,=12 ; ERR ,1,CPOPJ IDPB PNT2,$SBITS(PNT) POPJ P, ^RCBIT0: ;;#%%# ! JFR 2-1-75 SETOM RCDFLG MOVE A,[XWD SIMPLE,PROCED] ;PRETEND TO BE A SIMPLE PROCEDURE ORM A,BITS ;;# # NEEDED TO FIX BITS BACK IF RECORD CLASS WAS ALREADY FORWARD SKIPN PNT,GENLEF ;IF ANY POPJ P, PUSHJ P,GETAD ;FIND OUT WHAT THIS ID USED TO BE TDNN TBITS,[XWD EXTRNL,FORWRD] POPJ P, ;NOT ELIGIBLE TRZE TBITS,PNTVAR ;IF NOT A RECORD CLASS TRZN TBITS,SHORT POPJ P, ;THEN LEAVE IT ALONE ANDI SBITS,LLFLDM ; CAME SBITS,LEVEL ;SAME LEVEL?? POPJ P, ;NOPE EXTERN EQU EXCH SP,STPSAV ;SAME PNAME?? PUSH SP,$PNAME(PNT) PUSH SP,$PNAME+1(PNT) PUSH SP,PNAME PUSH SP,PNAME+1 PUSHJ P,EQU EXCH SP,STPSAV JUMPE 1,CPOPJ ;IF NOT, DO NOTHING TDO TBITS,[XWD SIMPLE,PROCED] MOVEM TBITS,$TBITS(PNT) ;IF SO, THEN MODIFY SO PRDEC POPJ P, ;WINS ^URCHLR: ;USER RECORD HANDLER PROCEDURE SPECIFICATION MOVE PNT,GENLEF+1 MOVEM PNT,URCIPR POPJ P, ^NRCDO: ;MAKES A NEW RECORD NONRC < MOVEI D,1 ;RESULT WILL COME BACK IN 1 PUSHJ P,STORZ >;NONRC NRC < PUSHJ P,ALLSTO MOVEI A,1 ;OP CODE FOR ALLOCATE PUSHJ P,CREINT ;MAKE AN INTEGER CONSTANT EMIT ;PUT OUT OP CODE >;NRC MOVE PNT,GENLEF+1 ;PICK UP CLASS PUSHJ P,ADRINS ;WILL NEED AN ADCON NONRC < EMIT >;NONRC NRC < EMIT XCALL ($RECFN) ;$RECFN(1,CLASSID) >;NRC MOVEI D,1 ;RESULT COMES BACK IN AC1 MOVEI TBITS,PNTVAR ; MOVE PNT,GENLEF+1 MOVEM PNT,RCLASS PUSHJ P,MARKME MOVEM PNT,GENRIG ;THE TEMP POPJ P, ^RCCERR: ERR ,1 POPJ P, ^RCPERR: ERR ,1 POPJ P, >;REC NOREC < ^NLLREC: ^RCCREM: ^SETIRP: ^TWDIRC: ^RCBIT0: ^URCHLR: ^NRCDO: ^RCCERR: ^RCPERR: ^RCFPIK: ^RCFREF: ^ENDRC: ERR >;NOREC ;; RCFPIK -- ROUTINE TO DECODE RECORD INDEX REC < EXTERN EQU ^RCFPIK: MOVE PNT,GENLEF+3 ;GET THE CLASS HLRZ PNT2,%TLINK(PNT) ;INTERESTING THINGS ARE IN SECOND BLOCK HLRZ PNT2,%TLINK(PNT2) JUMPE PNT2,RCFP.3 ;NO FIELDS, MUST LOSE MOVSS POVTAB+6 ;INCASE OF OVERFLOW EXCH SP,STPSAV ;GET THE STRING STACK RCFP.1: PUSH SP,$PNAME(PNT2) ;CHECK TO SEE IF THE SAME PUSH SP,$PNAME+1(PNT2) PUSH SP,PNAME ;THE ONE WE SCANNED PUSH SP,PNAME+1 ; PUSHJ P,EQU ;CHECK FOR EQUAL JUMPN 1,RCFP.2 ;YES HRRZ PNT2,%RVARB(PNT2) ;GO ON TO NEXT JUMPN PNT2,RCFP.1 ;IF THERE IS A NEXT RCFP.2: EXCH SP,STPSAV ;SAVE PDL AGAIN MOVSS POVTAB+6 ;PUT PDLOV BACK CAIN PNT2,0 ;DID WE GET ONE RCFP.3: ERR ,1 MOVEM PNT2,GENRIG ;UGH! IF LOSES, WILL DO SOMETHING ELSE POPJ P, >;REC ;; RCFREF -- EXEC ROUTINE FOR HANDLING RECORD FIELD REFERENCES REC < ^RCFREF: HRRZ PNT,GENLEF+1 ;GET THE RECORD ID PUSHJ P,GETAD ;GET THE SEMANTICS TRNE TBITS,PNTVAR ;BETTER BE SURE A POINTER VARIABLE TRNE TBITS,777777-(PNTVAR!GLOBL) ;BETTER LOOK LIKE THIS ERR ,1 NORGC < TLNE SBITS,ARTEMP ;A TEMP?? TLNE SBITS,FIXARR ;EVEN IF SO, FIXARR IS JUST NORMAL JRST RCR1 ;DO THE STANDARD CASE ;;% % treat all indxed temps in good way (unless later get in trouble) ; TLNN SBITS,INDXED ;INDEXED TEMP? ; JRST RUINDX ;NOPE, ASSUME CAME FROM SOME BAD THING ; HRRZ LPSA,$VAL2(PNT) ;THE SUBFIELD FLAG ; JUMPN LPSA,RCR1 ;A SUBFIELD INDEXED TEMP IS JUST NORMAL ; GENMOV (GET,MRK!INDX) ;GET THE INDEXED TEMP INTO AN AC TLNE SBITS,INDXED JRST RCR1 ;;% % >;NORGC RUINDX: PUSH P,PNT ;SINCE WILL REMOP RIGHT AWAY PUSHJ P,RCR1 ;GET A NEW INDEXED TEMP HRROS %TLINK(PNT) ;& MARK IT SO REMOP UNDOES REF COUNT POP P,LPSA ;FOR THE REMOP OF OUR ORIGINAL TEMP JRST REMOPL ;GO REMOP THE BEASTIE RCR1: GENMOV (ACCESS,0) ;GET ACCESS TO THE THING PUSHJ P,GETAN0 ;GET AN INDEX AC EMIT ;BE SURE OK XCALL <$RERR> ;MAY WANT SOMETHING BETTER LATER ;TOO BAD CANNOT ELIMINATE THE ;REDUNDENT CHECKING, AS IN ; X_FOOC:1[R]+FOOC:2[R] HLRZ LPSA,$ACNO(PNT) ;GET THE CLASS ID HRRZ PNT2,GENLEF+3 ;AS HE SPECIFIED IT PUSHJ P,SUBFOK ;TEST FOR CLASS AGREEMENT ERR ,1 HLRZ PNT2,%TLINK(PNT2) ;THE INTERESTING THINGS ARE IN THE SECOND GOTFS: MOVE PNT,GENLEF+2 ;GOT FIELD SEMANTICS SETZB TBITS,SBITS PUSHJ P,GETTEM ;GET A TEMP ;& FILL IN THESE BITS MOVE TBITS,$TBITS(PNT) HRLZI SBITS,ARTEMP!PTRAC!INDXED; PROMISE TO BE ARITHMETIC TLZ TBITS,OWN!FORMAL!MPBIND ;RANDOM BAD GUYS THAT MAY BE ON MOVEM SBITS,$SBITS(LPSA) MOVEM TBITS,$TBITS(LPSA) TLNE TBITS,SBSCRP ;ARRAYS ARE FUNNY HRLM PNT,$VAL2(LPSA) ;SAVES THE FIELD NAME SO THAT ARRSB WILL WIN TRNE TBITS,PNTVAR ;A POINTER ITSELF?? TRNE TBITS,ITMVAR!ITEM!SHORT TLZA D,-1 ;NO, JUST DO THE MARKING -- CLASSID 0 HLL D,$ACNO(PNT) ;THE CLASS ID OF THIS FIELD MOVEM D,$ACNO(LPSA) ;REMEMBER RCLASS,,ACNO ;;#SS# ! RHT ALSO REMEMBER IN ACKTAB HRRM LPSA,ACKTAB(D) ;REMEMBER I DID IT MOVE PNT,LPSA ;FOR TYPDEC MOVEM PNT,GENRIG ;THIS IS WHAT WE HAVE PUSHJ P,TYPDEC ;GET CORRECT TYPE MOVEM A,PARRIG ; HRRZ LPSA,GENLEF+2 ;GET THE SEMANTICS OF THE FIELD ID ;;%##% JFR 4-5-75 STRING SUBFIELDS ARE SPECIAL MOVE TBITS,$TBITS(LPSA) ;GET TYPE ;;%##% ! RHT 1-27-76 PROCED, TOO TDNN TBITS,[XWD SBSCRP,PROCED!ITEM!ITMVAR] ;THESE ARE BOGUS TRNN TBITS,STRING!DBLPRC JRST RCFNST ;NOT STRING OR DOUBLE HRLZ C,$ADR(LPSA) ;OFFSET ;;#WD# RHT 1-25-76 ; HRR D,$ACNO(PNT) ; HRL D,D PUSHJ P,GETAN0 ;GET ANOTHER AC HRL D,$ACNO(PNT) ;;#VA# ! RHT 9-13-75 USED TO BE MOVE MOVE A,[HRROI USADDR!USX!NORLC!INDRCT] ;ASSUME STRING TRNE TBITS,DBLPRC HRLI A,() ;WAS DOUBLE PUSHJ P,EMITER ;GET ADDR (WD2 OF STRING, WD1 OF LONG) IN AC HRL D,PNT ;SAVE OLD TEMP IN $ACNO OF NEW PUSH P,TBITS SETZB TBITS,SBITS ; PUSHJ P,GETTEM ;GET NEW TEMP FOR STRING INDEXED TEMP MOVEM D,$ACNO(LPSA) ;RECORD TEMP,,STRING TEMP AC HRRM LPSA,ACKTAB(D) MOVEI TBITS,INTEGR ;MAKE OTHER ONE STERILE MOVEM TBITS,$TBITS(PNT) ; MOVEI TBITS,STRING POP P,TEMP TRNE TEMP,DBLPRC MOVEI TBITS,DBLPRC!FLOTNG HRLZI SBITS,ARTEMP!PTRAC!INDXED MOVEM TBITS,$TBITS(LPSA) ;MAKE IT A STRING INDEXED TEMP MOVEM SBITS,$SBITS(LPSA) ; SETZM $VAL(LPSA) ;INDEX IS NOW ZERO HLLOS $VAL2(LPSA) ;BUT STRING IS STILL SUBFIELD TEMP MOVEM LPSA,GENRIG ;THIS IS THE RIGHT TEMP ;;#WD# ^ JRST RCF001 ; RCFNST: ;;%##% ^ HRRE B,$ADR(LPSA) ;ADR FIELD IS THE INDEX MOVEM B,$VAL(PNT) ;REMEMBER IT AS SUCH RCF001: HLLOS $VAL2(PNT) ;JUST USE -1 AS A FLAG FOR NOW NORGC < MOVE PNT2,TPROC ;PUT ON SUBFIELD TEMP RING HLRZ PNT2,%TLINK(PNT2) ;IT IS HOMED IN THE SECOND PROC SEMBLK HRLZ LPSA,PNT2 ;BACK POINTER IS INTO PROC SEMBLK HRR LPSA,%RVARB(PNT2) ;THE FIRST THERE NOW MOVEM LPSA,%RVARB(PNT) ;LINKS FOR NEW SUBFIELD TRNE LPSA,-1 ;AM I THE VERY FIRST SUCH? HRLM PNT,%RVARB(LPSA) ;NOPE, HE LINKS BACK TO ME NOW HRRM PNT,%RVARB(PNT2) ;NEW LIST HEADER MOVE PNT2,GENLEF+1 ;THE RECORD POINTER AGAIN HRLM PNT2,%TLINK(PNT) ;BOY IS ALL THIS HAIRY ;POINTS BACK SO THAT DEREF KLUGE WORKS >;NORGC POPJ P, ;NOTE THAT I DON'T EVEN DO A REMOP YET ON THE RECORD POINTER ; THE REMOP WILL HAPPEN AUTOMATICALLY WHEN I REMOP THE NEW INDEXED TEMP >;REC ;; RECORD TYPE JUSTIFICATION ROUTINE REC < ^SUBFOK: CAMN LPSA,PNT2 ;TAKES A CLASS OR CLASS LIST IN PNT2 & LPSA JRST SBFSKP ;SKIP RETURNS IF HAVE NON ZERO INTERSECTION ;CHANGES NO ACS CAIE LPSA,-1 ;IF EITHER IS THE UNIVERSAL CLASS CAIN PNT2,-1 ;WE WILL KNOW WE ARE WINNING JRST SBFSKP ;;#YU# 3! JFR 2-3-77 TRNE LPSA,-1 TRNN PNT2,-1 JRST SBFRET ;PROTECT AGAINST ILM OR PDLOV ON BAD ARGUMENTS PUSHJ P,SBFTRY ;TRY SUBFIELDING JRST [ ;LOST, TRY OTHER CASE EXCH PNT2,LPSA ; PUSHJ P,SBFTRY ;SKIP RET MEANS WINNER SOS (P) ;UNDO WINNAGE EXCH PNT2,LPSA ; JRST SBFSKP ] SBFSKP: AOS (P) ;A GREAT WIN SBFRET: POPJ P, SBFTRY: PUSH P,C ;VERIFY CLASS OK PUSH P,TEMP PUSH P,LPSA MOVE C,$TBITS(LPSA) TRNN C,LSTBIT ;THIS BIT IS THE GIVEAWAY JRST POPOFF ;LOSER HRRZ C,$PNAME(LPSA) ; MOVE TEMP,$PNAME+1(LPSA) LPLP.1: JUMPE C,POPOFF ILDB LPSA,TEMP ; PUSHJ P,SUBFOK ;TEST IT OUT SOJA C,LPLP.1 ;LOOP BACK AOS -3(P) ;WILL SKIP RET ONLY IF LOSE POPOFF: POP P,LPSA POP P,TEMP POP P,C POPJ P, >;REC ;; ROUTINE TO HANDLE REFERENCE COUNT ADJUSTMENT REC < NORGC < ;;ROUTINE TO EMIT A DEREFERENCEING INSTRUCTION FOR THE THING IN PNT ;;WILL EVENTUALLY EMIT A , USUALLY. IF HOWEVER THE THING ;;HAS DANGLING REFERENCES IN THE FORM OF INDEXED TEMPS, WILL INSTEAD ;;EMIT CODE TO ADJUST THE REFERENCE COUNT BY N+C, WHERE N IS THE ;;NUMBER OF SUCH TEMPS, AND C IS USUALLY -1. (IF C=0, THEN THE EFFECT ;;OF THIS ROUTINE WILL BE TO "CORRECT" THE REFERENCE COUNT -- USEFUL ;;WHEN YOU MUST PASS A RECORD BY REFERENCE). IF N+C LSS 0, THEN THE CODE ;; WILL BE PUT OUT ABS(N+C) TIMES. OTHERWISE THE COUNT IS BUMPED ;;BY ABS(N+C). IN ANY EVENT, ANY SUCH TEMPS THAT POINT TO THE PNT THING ARE ;;MARKED (BY SETTING THEIR BACK REFERENCE POINTER (LH OF %TLINK) TO -1) ;;SO THAT THEY WILL EMIT A WHENEVER THEY GET REMOPPED ;;AND THE THING IN PNT WILL GET ITS REFCOUNT BUMPED BY THAT MUCH. ;; ;;PARAMETERS: PNT = THING ;; C = INITIAL OFFSET COUNT = "TRUE" ADJUSTMENT ;; SET TO -1 FOR SIMPLE DEREFERENCING ;; SET TO 0 FOR REF PARAM "CORRECTION" ;;ENTRY POINTS: ;; ^RFCADJ: ;; ;;MODIFIES LPSA,C,A,TEMP ^RFCADJ: PUSH P,FF PUSH P,PNT2 PUSH P,D ;BECAUSE ACCESS MAY MUNGE PUSH P,TBITS PUSH P,SBITS PUSH P,B HRRZ B,TPROC ;WILL CRAWL DOWN DEPENDENTS LIST HLRZ B,%TLINK(B) ;POINTER IS IN SECOND BLOCK JRST CKL.1 ;COUNT UP CKL: HLRZ LPSA,%TLINK(B) ;BACK POINTER CAIN LPSA,(PNT) ;IS THIS ONE? JRST [ HRROS %TLINK(B) ;THIS WAS ONE, MARK IT AOJA C,.+1 ;AND BUMP THE COUNT ] CKL.1: HRRZ B,%RVARB(B) ;GO ON TO NEXT JUMPN B,CKL LCKD: JUMPE C,RFCXIT ;HAVE TO ADJUST COUNT? PUSH P,C ;WHAT A PARANOID GENMOV (ACCESS,GETD) ;GET ACCESS POP P,C JUMPG C,BMCNT ;MUST INCREMENT MOVE A,[RECUUO 0,NOUSAC] ;DROP COUNT BY ONE PUSHJ P,EMITER ;EMIT IT AOJL C,.-1 ;HANG IN THERE UNTIL DONE RFCXIT: POP P,B POP P,SBITS POP P,TBITS POP P,D POP P,PNT2 POP P,FF POPJ P, BMCNT: EMIT ;FETCH THE RECORD ADDRESS XCALL <$RERR> ;BETTER NOT BUMP REF COUNT OF NULL HRLOI A,() ;SHOULD PUT )> INTO A TLZ FF,RELOC ;AN ABSOLUTE VALUE PUSHJ P,CODOUT ;EMIT ONE OF THESE SOJG C,.-1 ;PUT OUT A MESS OF THEM JRST RFCXIT ;DONE >;NORGC >;REC DSCR MAKBUK, FREBUK CAL PUSHJ PAR current value of SYMTAB DES MAKBUK allocates a new Semblk, copies current Symtab bucket list into it; saves a pointer to the old one -- see main SAIL data descriptions for details. This is how scope is handled, because... FREBUK deletes this Semblk, restores old pointer. It is up to somebody else (ALOT) to delete all the local Semblks which are no longer available via SYMTAB This junk is unnecessary for STRCON and CONST buckets, since all such entities are global (one bucket list) SEE main SAIL data definitions in SAIL SEE BLOCK, UP1, UP2, etc.  ^MAKBUK: GETBLK ;MAKE A NEW BLOCK EXCH LPSA,SYMTAB ;SYMTAB IS NOW UPDATED HRLI PNT,(LPSA) HRR PNT,SYMTAB ;PREPARE TO BLT HRRZM LPSA,BLKLEN-1(PNT) ;TIE TO OLD ONE MOVE TEMP,PNT BLT PNT,BLKLEN-2(TEMP) ;COPY BUCKET POPJ P, ^FREBUK: MOVE LPSA,SYMTAB HRRZ A,BLKLEN-1(LPSA) ;TIE MOVEM A,SYMTAB FREBLK ;RELEASE THE BLOCK POPJ P, BEND GENDEC SUBTTL ERROR MESSAGE EXECS BEGIN ERRORS ;THE FIRST ROUTINE ALWAYS PRINTS OUT A NEAT MESSAGE.... JOBERR__42 DEFINE XX (NAME,MESSG,CODE) < ^NAME : ERR. 1,[ASCIZ/MESSG/] ;;##LN##KVL - MAKES EXECUTION OF BAD CODE HARDER IFN CODE,< HLLOS JOBERR ;CAUSES LOADER TO DELETE EXECUTION (HOPEFULLY) >;CODE POPJ P, >;XX XX (ER1,,1) XX (ER2,,1) XX (ER3,,0) XX (ER4,,1) XX (ER5,,0) XX (ER6,,0) XX (ER7,,2) XX (ER8,,0) XX (ER15,,0) XX (ER24,,1) XX (ER33,,1) XX (ER34,,1) XX (ER35,,0) XX (ER36,,0) XX (ER37,,0) XX (ER38,,1) XX (ER39,,1) XX (ER40,,0) XX (ER41,,1) XX (ER48,,0) XX (ER59,,1) ;;#WS# 1! JFR 4-18-76 NEW GRAMMAR HAS THIS ERROR FOR EXPRESSION CASE ONLY XX (ER66,,1) XX (ER68,,1) XX (ERTRAP,,1); DEFINE YY (NAME,MESSG) < ^NAME: ;SHOULD REALLY BE AN ERRPRI PUSH P,A MOVEI A,[ASCIZ /MESSG /] PUSHJ P,PRINT. POP P,A POPJ P, > YY (ERR101,) YY (ERR102,) YY (ERR103,) YY (ERR104,) YY (ERR105,) YY (ERR106,) YY (ERR107,) YY (ERR108,) YY (ERR109,) YY (ERR110,) YY (ERR111,) XX (ERR112,,1) XX (ERR113,,1) XX (ERR114,,1) XX (ERR115,,1) XX (ERR116,,1) XX (ERR117,,1) XX (ERR118,,1) XX (ERR119,,1) XX (ERR120,,1) XX (ERR121,,1) XX (ERR122,,1) XX (ERR123,,0) XX (ERR124,,1) ;; #QT# BETTER DIAGNOSTIC FOR ELSE XX (ERR125,,1) DSCR SCNBAK,POPBAK,KILPOP,QREM2,QTYPCK; PRO SCNBAK,POPBAK,KILPOP,QREM1,QREM2,QTYPCK; DES Error recovery execs: SCNBAK: backs scanner up by one token. POPBAK: returns you to the previous production. KILPOP: returns the production control stack (stack productions pushj,popj stuff) to its pristine state. QREM1,QREM2: Called at the end of a block to delete untyped identifiers still left on the VARB ring. QTYPCK: Called from PRE in TOTAL. Every time one GENMOVs with CONVRT on, QTYPCK checks to see if the type bits of either the source or destination are zero in the rh, and gives the untyped one the type of the other. If the source is undeclared, then QTYPCK corrects the source, and if the source is a temp, it corrects the procedure or array that generated the temp.  ;BACKS THE SCANNER UP BY ONE TOKEN ^SCNBAK: MOVE A,PARLEF MOVEM A,SAVPAR MOVE A,GENLEF MOVEM A,SAVSEM TLO FF,BAKSCN ;SCANNER IS AHEAD. POPJ P, ;RETURNS YOU TO THE PREVIOUS PRODUCTION ^POPBAK: MOVE A,SAVPOP MOVEM A,-2(P) ;PRODUCTION POINTER. POPJ P, ;FLUSHS THE PRODUCTION CONTROL STOCK (used for the production pushj popj stuff) ^KILPOP: MOVE TEMP,PCSAV ; GET PRODUCTION CONTROL STACK POINTER KPJ: SKIPGE -1(TEMP) ; IS THIS THE JUMP TO PARSE JRST KILDUN ; YES, LEAVE IT AND GO HOME POP TEMP,-1(TEMP) ; NO, GO DOWN ONE JRST KPJ KILDUN: MOVEM TEMP,PCSAV POPJ P, ;CALLED AT THE END OF A BLOCK TO DELETE THE UNTYPED IDENTIFIERS(EXCEPT PROCEDURES) ^QREM1: SKIPA LPSA,GENLEF+1 ; GET THE BLOCK ^QREM2: MOVE LPSA,GENLEF+2 JUMPE LPSA,QFIN ; THIS BEGIN HASN'T A BLOCK SEMBLK QL: HRRZ LPSA,%RVARB(LPSA) ; GO RIGHT ON VARB RING... QL1: JUMPE LPSA,QFIN ; UNTIL YOU GET TO THE END. MOVE TBITS,$TBITS(LPSA) ; THE TYPE... JUMPN TBITS,QL ; IS OKAY... HRRZ TBITS,%RVARB(LPSA) ;SAVE THE NEXT GUY.......... PUSHJ P,DESTRO ; KILL THE BASTARD! MOVE LPSA,TBITS JRST QL1 QFIN: POPJ P, ;DESTROYS AN IDENTIFIER - REMOVES FROM VARB RING - NULLIFIES HASH AND STR RING ^QDESID: MOVE LPSA,GENLEF+1 ; GET THE FATED IDENTIFIER DESTRO: TLNE FF,CREFSW PUSHJ P,CREFDEF ; DEFINE WHAT WE'RE KILLING TO CREF PUSHJ P,URGSTR PUSHJ P, URGVRB ; UNRING IT FREBLK (LPSA) POPJ P, ;CALLED FROM PRE OF GENMOV - CHANGES UNTYPED TO A REASONABLE TYPE ^QTYPCK: TRNN TBITS,-1 ; IS THE SOURCE OF UNDECLARED TYPE JRST QMATCH ; YES, GO GIVE IT THE DESTINATIONS TYPE TRNE B,-1 ; IS THE DESTINATION UNTYPED POPJ P, ; NO, GO HOME HRR B,TBITS ; YES, GIVE IT THE SOURCE TYPE POPJ P, QMATCH: HLR TBITS,$SBITS(PNT) ; GET SOURCE SEMANTICES HRRM B,$TBITS(PNT) ; GIVE THE SOURCE THE DESTINATION TYPE TLNN TBITS,INAC!ARTEMP!INUSE ; IS IT A TEMP JRST .+3 ; NO, GO BACK HLR TBITS,%TLINK(PNT) ; GET THE ARRAY OR PROCEDURE HRRM B,$TBITS(TBITS) ; GIVE IT THE GOOD TYPE HRR TBITS,B ; GIVE TBITS THE GOOD TYPE POPJ P, DSCR UNDEC -- Undeclared identifiers; PRO UNDEC; DES Declares an identifier globally or locally and modifies symbol table nicely. When the token I is scanned at the identifier switch areas S1 and EX1 in HEL, we call UNDEC. Since TYPDEC (called by the scanner) returns I if there are no type bits on, we may have merely an untyped identifier, so we don't need to declare it again. Otherwise, we create an empty semblk, then link it on the appropriate varb ring, hash bucket and string ring for global or local declaration. We make the assumption that the user has declared something in the global block, and thus use the block semblk referenced by QQBLK which is loaded at the first call of the exec BLOCK.  ;ENTERS IDENTIFIER ON LOCAL OR GLOBAL LEVEL ^UNDEC: SKIPE A,GENLEF ; IF THE THING IS DECLARED... POPJ P, ; THEN GO BACK ELSE... HRRZI LPSA,PNAME-1 ;SET UP LPSA WITH IDD'S NAME ERR ,3 HRRZI A,INTEGR ; SOMETHING SIMPLE TO DECLARE MOVEM A,BITS PUSHJ P,ENTERS ; GO MAKE IT MOVE A,NEWSYM ; GET IT BACK MOVEM A,GENRIG ; PUT IT OUT POPJ P, ; RETURN ;;%AC% REMOVE GLOBAL DECLARATION OPTION IFN 0 < ;The following is how to declare an identifier in the outermost block. ;Social pressures forced its removal from the error recovery, but I ;thought I'd leave it around for a while in case the algorithm is needed ;for another purpose. -kvl GLOBA: SKIPN PNT,QQBLK ; GET THE HIGHEST BLOCK WITH DECLARATION JRST LOCA ; WE ARE THE HIGHEST BLOCK GETBLK NEWSYM ; GET A NEW SEMBLK MOVE LPSA,NEWSYM HRROI PNT2,PNAME+1 ; PDP FOR NAME POP PNT2,$PNAME+1(LPSA) POP PNT2,$PNAME(LPSA) PUSHJ P,RNGSTR ; PUT IT ON THE STRING RING HRRZ PNT,%RVARB(PNT) ; THE FIRST MEMBER OF BLOCK'S VARB RING HRRZ PNT2,$SBITS(PNT) ; GET THE LEVELS,ZERO THE SBITS MOVEM PNT2,$SBITS(LPSA) HRLM LPSA,%RVARB(PNT) ; LPSA _ 1ST HRRM PNT,%RVARB(LPSA) ; LPSA PNTS TO 1ST MOVE PNT,QQBLK ; GET THE HIGHEST BLOCK HRRM LPSA,%RVARB(PNT) ; BLK IN LPSA HRLM PNT,%RVARB(LPSA) ; BLK _ LPSA MOVE PNT,HPNT ; GET HASH(BUCK(QQBLK)) INTO B SUB PNT,SYMTAB ; CORRECT ADDRESS TO... MOVE C,PNT ; GENERALIZED HPNT FOR LATTER MOVE PNT2,QQBLK HRRZ PNT2,%TBUCK(PNT2) ADD PNT,PNT2 ; ... TO THE OUTER LEVEL XCT PNT HRRZ B,LPSA ; B = HASH(BUCK(QQBLK)) HRRZ A,SYMTAB ; INITIALIZE ;GO UP THE BLOCKS, FIXING THE HASH BUCKETS OR HASH CHAINGS THAT USED TO PT TO B HASHL: MOVE PNT,C ; GET GENERAL HPNT ADD PNT,A ; CORRECT HPNT TO THIS LEVEL XCT PNT ; LPSA PNTS TO HEAD OF HASH CHAIN THIS BUCKET HRRZ PNT2,LPSA CAMN B,PNT2 ; DOES B = HASH(BUCK(A)) ? JRST BUCIT ; YES,GO FIX THIS BUCKET SKIPN QQFLAG ; NO, FIX THE CHAIN. JRST UPBUCK ; WE ALREADY FIXED THE CHAIN,GO UP A BLOCK SETZM QQFLAG ; MAKE SURE WE ONLY DO THIS ONCE UPCHAI: MOVE PNT,PNT2 ; FIND THE TOP GUY OF THE CHAIN BEFORE QQBLK LEVEL HRRZ PNT2,%TBUCK(PNT2) ; GO UP CAME B,PNT2 ; ARE WE AT QQBLK LEVEL YET? JRST UPCHAI ; NO, GO UP THE CHAIN HRRZ PNT2,NEWSYM ; GET THE GUY HRRM PNT2,%TBUCK(PNT) ; TOP-NOT-ON-QQBLK-GUY PNTS TO UNDECLARED-GUY HRRM B,%TBUCK(PNT2) ; UNDECLARED-GUY PNTS TO 1ST-OF-QQBLK-LEVEL-GUY JRST UPBUCK ; FINE, GO UP A BUCKET BUCIT: MOVE PNT2,NEWSYM ; WE ARE GOING TO FIX THE BUCKET BY HRRM LPSA,%TBUCK(PNT2) ; DOING A REGULAR HASH HRR LPSA,PNT2 TLO PNT,2000 XCT PNT JRST UPBUCK ; GO UP A BUCKET UPBUCK: MOVE PNT,QQBLK ; GET THE TOP BUCKET HRRZ PNT,%TBUCK(PNT) CAMN A,PNT ; ARE WE AT THE TOP JRST .+3 ; YES, GO HOME HRRZ A,BLKLEN-1(A) ; NO, GO UP A BUCKET JRST HASHL ; NO TRY AGAIN MOVE PNT,NEWSYM ; PUT OUT, RESTORE, AND QUIT MOVEM PNT,GENRIG SETOM QQFLAG POPJ P, >; IFN 0 ZERODATA ^^QQFLAG:0 ^^QQBLK: 0 ENDDATA DSCR QDEC0,1,2 QARSUB QARDEC QPARM QPRDEC; PRO QDEC0,QDEC1,QDEC2,QSUBSC,QARDEC,QPARM,QPRDEC. DES These execs finish the declaration of an undeclared identifier by giving it a type and appropriate goodies. The QDEC execs determine the type from the token put in PARRIG by the productions. If we need an array, we count the dimensions with QSUBSC, install them and put out a temp in QARDEC. If we need a procedure, we get a second semblk in QDEC, ring on formals in QPARM, install parmeter counts in QPRDEC, and jrst to QARDEC to generate a temp (we assume all procedures are integer functions).  ;EXECS TO SET THE TBITS FROM THE PARSE TOKEN ^QDEC2: MOVEI A,0 ; RIGHT - TOP JRST .+4 ^QDEC0: SKIPA A,[0] ; RIGHT - ONE DOWN ^QDEC1: SKIPA A,[1] ; RIGHT - ONE DOWN SKIPA B,[0] ; LEFT - TOP MOVEI B,1 ; LEFT - ONE DOWN HRRZ PNT, PARRIG(A) ; GET IT MOVEI TBITS,0 CAMN PNT, %ILB ; LABEL JRST [TRO TBITS,LABEL+FORWRD ERRPRI JRST .+15] CAMN PNT, %ISV ; SET JRST [TRO TBITS,SET ERRPRI JRST .+13] CAMN PNT,%ARID ; AN ARRAY JRST [TLO TBITS, SBSCRP!SAFE ERRPRI JRST .+11] CAMN PNT,%PCALL ; A PROCEDURE JRST .+4 CAMN PNT,%S ; ANOTHER PROCEDURE JRST .+2 CAMN PNT,%FCALL ; YET ANOTHER PROCEDURE JRST [MOVE TBITS, [XWD EXTRNL,PROCED!INTEGR] ERRPRI JRST .+3] CAMN PNT,%ITV ; ITEMVAR JRST [TRO TBITS, ITMVAR!INTEGR ERRPRI JRST .+1] ; IVB GETS NO BITS CAME PNT,%S ; DONT TURN ON THE CLASIDX IF S HRLI PNT,CLSIDX ; ALL VARIABLES ARE CLASS MEMBERS MOVEM PNT,PARRIG(A) ; PUT IT OUT MOVE PNT,GENLEF(B) ; GET THE UNDECLARED GUY (from UNDEC) TLNE TBITS, SBSCRP ; IS IT AN ARRAY SETZM ,DIMNO ; YES, ZERO THE NUMBER OF DIMENSIONS TRNE TBITS,PROCED ; IF ITS A PROCEDURE... JRST [GETBLK ; GET A 2D BLOCK HRLM LPSA,%TLINK(PNT) ; PUT A PNTR TO IT IN TLINK OF PROC MOVEW %%VARB,VARB ; SAVE THE CURRENT VARB SETZM VARB ; INITIALIZE A NEW VARB JRST .+1] MOVEM TBITS,$TBITS(PNT) ; GIVE IT ITS TYPE MOVEM PNT,GENRIG(A) POPJ P, ;;# # BY JFR ZERODATA AND ENDDATA MACROS USED TO BE MISSING ZERODATA (BUG FIX 9-26-74) %%VARB:0 ENDDATA ;;# # ^QSUBSC: AOS ,DIMNO ; COUNT DIMENSIONS MOVE PNT, GENLEF +1 ; THE EXPRESSION TEMP .. PUSHJ P,REMOP ; GETS REMOVED POPJ P, ;;#VT# JFR 11-9-75 ZERODATA MACRO WAS MISSING ZERODATA(RANDOM) DIMNO: 0 ENDDATA ;;#VT# ^ ^QARDEC: MOVE PNT2,GENLEF+2 ;GET THE ARRAY (OR PROCEDURE) MOVE PNT,DIMNO ; GET #OF DIMENSIONS HRLM PNT,$ACNO(PNT2) ; RECORD IT MOVEI TBITS,0 ; TYPE IT MOVEI D,1 ; DUMMY AC NUMBER FOR ... PUSHJ P,MARKME ; CREATING A TEMP. HRL PNT,PNT2 ; PTR TO ARR (OR TO PROC) IN %TLINK( the temp) MOVEM PNT,GENRIG ; PUT IT OUT POPJ P, ^QPARM: MOVE PNT,GENLEF+2 ; GET THE PROCEDURE HLRZ PNT2,%TLINK(PNT) ; THE SECOND BLOCK PUSH P,PNT2 ; SAVE IT MOVE LPSA,GENLEF+1 ; GET THE EXPRESSION HRRZ TBITS,$TBITS(LPSA) ; GET ITS TYPE TLO TBITS,VALUE ; MAKE ALL PARAMETERS VALUE... TRNE TBITS,PROCED ; EXCEPT PROCEDURE EXPRESSIONS TLC TBITS,VALUE!REFRNC MOVEM TBITS,BITS TRNE TBITS,STRING ; IF IT IS A STRING AOS ,$NPRMS(PNT2) ; INCREMENT STRING PARM COUNT HLRZ TEMP,$NPRMS(PNT2) ; ALWAYS INCREMENT ARITH PARM COUNT AOJ TEMP, HRLM TEMP,$NPRMS(PNT2) GETBLK ; MAKE A FORMAL MOVEM TBITS,$TBITS(LPSA) ; GIVE IT A TYPE PUSHJ P,RNGVRB ; PUT IT ON THE VARB RING POP P,PNT2 ; GET 2ND BLOCK BACK SKIPN %TLINK(PNT2) ; IS THIS THE FIRST FORMAL HRLM LPSA,%TLINK(PNT2) ; YES, PUT A POINTER TO IT IN ; 2D BLOCK OF THE PROCEDURE MOVE PNT,GENLEF +1 ; GET THE EXPRESSION AND.... JRST REMOP ; KILL IT!!!!! , THEN RETURN QUIETLY ^QPRDEC: MOVE PNT,GENLEF+2 ;GET THE PROCEDURE HLRZ PNT2,%TLINK(PNT) ; GET THE 2D BLOCK HLRZ TEMP,$NPRMS(PNT2) ; INCREMENT ARITH PARM COUNT AOJ TEMP, HRLM TEMP,$NPRMS(PNT2) HRRZ TEMP,$NPRMS(PNT2) ; STRING PARM COUNT * 2 LSH TEMP,1 HRRM TEMP,$NPRMS(PNT2) MOVEW VARB,%%VARB ; RESTORE CURRENT VARB JRST QARDEC ; ASSUME FUNCTION (i.e. make a temp) BEND SUBTTL EXECS to handle string constants as comments BEGIN SCOMM DSCR SCOMM PRO SCOMM DES Remove the damage done by using a string constant as a comment preceding a statement  COMMENT  last prod at S1: STC drarrow EXEC SCOMM SCAN S1 #Q6  ^SCOMM1: SKIPA PNT,GENLEF+1 ;SEMANTICS FROM GENLEF+1 ^SCOMM: MOVE PNT,GENLEF ;SEMANTICS OF CONSTANT PUSHJ P,GETAD ; TRNN TBITS,STRING ;MUST BE A STRING CONSTANT JRST [ERR ,1 POPJ P,] JRST REMOP BEND SCOMM SUBTTL START!CODE (inline) EXECS BEGIN INLINE ZERODATA (START!CODE VARIABLES) ?ACSWCH: 0 ;ACCESS HAS BEEN SEEN (-1) OR NOT (0) ?CODSEM: 0 ;SEMANTICS OF ADDRESS FIELD (IF VBL) ?CODVAL: 0 ;VALUE OF ADDRESS, AC, INDEX FIELDS (CONST STUFF) ?INSTBL: 0 ;PTR TO SIXBIT TABLE OF OPCODES, IF HAS BEEN READ IN ?OPCOD: 0 ;OPCODE OF INSTRUCTION BEING ASSEMBLED ;OPDUN -- on if opcode field has been scanned. Also used as flag ; to EMITER that the instruction going out is a START!CODE ; produced intruction -- avoids optimizations of various forms ^OPDUN: 0 DATA (START!CODE VARIABLES) ; THIS IS THE ENTER BLOCK FOR THE SIXBIT OPCODE TABLE USED TO ; ALLOW SYMBOLIC OPCODES IN START!CODE INSTRUCTIONS NOTENX < TNAME: OPNAME 'OPS ' TWORD3: 0 TPPN: OPPPN >;NOTENX ENDDATA DSCR CODNIT, WRDNIT, ONEWRD, SETSIX, SETOP, CODIND, CODREG, etc. PRO CODNIT WRDNIT ONEWRD SETSIX SETOP CODIND CODREG CODLIT ERRCOL ERRCOM DES These routines handle the START!CODE/QUICK!CODE syntax. The only surprise is a table of SIXBIT opcodes which are read in when needed. No variable with the same name as one of these opcodes may be used within a CODE block.  ^CODNIT: JRST .+1(B) ;START!CODE CLEARS, QUICK!CODE DOESN'T PUSHJ P,ALLSTO ;CLEAR THE WORLD OPTSYM %$SCOD ;START OF HAND CODE ; JRST WRDNIT ;FALL THROUGH ^WRDNIT: SETZM ACSWCH ;RESET ACCESS SWITCH SETZM OPCOD ;OP, AC, INDEX, INDR COLLECTED HERE SETZM OPDUN SETZM CODVAL ;OPDUN IS A FLAG, CODVAL IF CONST SETZM CODSEM ;SEMANTICS OF ADDR IF NON-CONST ;;#JU# RHT (DEL 1 LINE) -- DONT HURT ACKTAB 10-23-72 MOVSI TEMP,INLIN ;SET SPECIAL SCANNER BIT SO THAT ORM TEMP,SCNWRD ; @ IS TREATED AS A DELIM, ; (DCS -- 8/13/70) PNAME+1 ZEROED NOCODE: POPJ P, ^ONEWRD: SKIPE A,OPCOD HRRZS CODVAL OR A,CODVAL HRL C,A HLLZS A ;PUT OP CODE,UNRELOC ADDR IN PLACE SKIPN OPDUN ;WAS ANYTHING SEEN? JRST NOCODE ; NO, NULL STATEMENT SETOM OPDUN ;TELL EMITER DOING INLINE CODE TRO A,NOUSAC!USADDR!NORLC ;ASSUME CONSTANT ADDR FIELD SKIPN PNT,CODSEM ;WELL, WHICH IS IT? JRST EMITER ;EMIT IT MOVE TBITS,$TBITS(PNT) ;GET BITS FOR FXTWO SET TRC A,USADDR!NORLC!FXTWO ;ASSUME A STRING ;; #JRL# 9-19-72 A STRING ITEMVAR IS NOT A STRING ;;#VM# ! JFR 10-30-75 NEITHER IS A STRING PROCEDURE TDNN TBITS,[XWD SBSCRP,ITEM!ITMVAR!PROCED] ;IF SBSCRP OR STRING, ;; #JRL# TRNN TBITS,STRING ; REVERSE ASSUMPTION TRZ A,FXTWO ;; #PK# 12-2-73 DO A REMOP HERE PUSHJ P,EMITER ;GO EMIT CODE JRST REMOP ;REMOP IT ;; #PK# ^SETSIX: MOVEI A,0 ;COLLECT SIXBIT HRRZ TEMP,PNAME ;LENGTH JUMPE TEMP,.+2 ;IGNORE NULL STRINGS CAILE TEMP,6 ;MUST BE OPCODE-SIZED POPJ P, ; NO PRINT NAME, NO SIXBIT MOVE C,[POINT 6,A] MOVE LPSA,PNAME+1 ;BYTE POINTER TO STRING LOOP: SOJL TEMP,LOKSIX ;GOT IT CONVERTED, LOOK IT UP ILDB D,LPSA ;GET CHAR SUBI D,40 IDPB D,C ;COLLECT SIXBIT JRST LOOP LOKSIX: Comment  might be an OPCOD -- will assume it is if it is in the opcode table. To find out, we may have to read said table in. Then we will do a linear search to discover the correct instruction code  NOTENX < SKIPE B,INSTBL ;TABLE IN CORE? JRST TABLIN ;YES, ADDRESS IN B ;;#GN# DCS 2-6-72 (1-1) INCLUDE UUO'S, STANFORD UUO'S EXPO < SIZZZZ__700-40 >;EXPO NOEXPO < SIZZZZ__724-40 >;NOEXPO MOVEI C,SIZZZZ+4 ;SIZE OF TABLE, PLUS BREATHING ROOM ;; #GN# PUSHJ P,CORGET ;GET SOME SPACE FOR IT ERR SUBI B,1 HRLI B,-SIZZZZ ;IOWD -SIZE,ADDR-1 FOR OP TABLE MOVEM B,INSTBL ;STORE ITS ADDRESS MOVEI B+1,0 ;END COMMAND LIST SETZM TWORD3 MOVE TEMP,[OPPPN] MOVEM TEMP,TPPN ;RESTORE OPCODE FILE PPN OPEN 17,[17 OPDEV 0] ERR LOOKUP 17,TNAME ERR INPUT 17,B ;READ THE OP TABLE RELEASE 17, >;NOTENX TENX< SKIPE INSTBL ;TABLE READ IN? JRST TABLIN ;YES PUSH P,A GSYSIN ;[clh] SYSIND (=B) _ 0 tenex, 2 T20 MOVE B,[OPFILE]+1(SYSIND) ;[clh] HRLZI A,100001 ;OLD FILE, SHORT FORM JSYS GTJFN ERR HRLI A,400000 ;XWD FORK, JFN JSYS GET ;OPFILE IS SSHARED SETOM INSTBL ;MARK THAT THE TABLE IS HERE POP P,A >;TENX TABLIN: Comment  B pnts to current table entry (LH IS -COUNT) A is soon be sixbit for OPcode being sought  NOTENX< MOVE D,[CAME A,(B)] ;SET UP QUICK SEARCH LOOP MOVE D+1,[AOBJN B,D] ;ITERATION CONTROL MOVE D+2,[JRST TSTFND] ;OUT OF ACS AOJA B,D ;INITIAL ADD TSTFND: JUMPGE B,UNFNDOP ;SEARCH EXHAUSTED FNDOPC: SUB B,INSTBL ;GET OP CODE IN OCTAL ;; #GN# ADDI B,37 ;ADJUST -- FIRST 40 NOT LOADED ;;#GN# (1-1) MOVEM B,GENRIG ;STORE FOR A WHILE MOVE TEMP,%OPC ;MARK OPCODE FOUND MOVEM TEMP,PARRIG ;SAVE FOR PARSER UNFNDOP: POPJ P, >;NOTENX TENX< COMMENT ! In TENEX, the opcode table is created by MAKTAB.TNX to be a SSAVEd file. It consists of the operations names (in sixbit), their opcodes, in bucket-driven link lists. ! OPBUKT__=307 ;NUMBER OF BUCKETS BUKPAG__600 ;STARTING PAGE FOR OPTABLE BUKTST__BUKPAG*1000 ;STARTING ADDR FOR BUCKETS MOVM B,A ;ABS(OPCODE) IDIVI B,OPBUKT ;COMPUTE BUCKET NUMBER IN C MOVE B,BUKTST(C) ;GET BUCKET POINTER TABLI1: CAMN A,(B) ;IS THIS THE RIGHT OPCODE? JRST FNDOPC ;YES SKIPN B,2(B) ;CDR DOWN LIST, ARE WE TO NIL JRST UNFNDOP ;YES, NO MORE JRST TABLI1 ;NO, KEEP GOING FNDOPC: MOVE B,1(B) ;PICK UP THE OPCODE MOVEM B,GENRIG ;STORE FOR A WHILE MOVE TEMP,%OPC ;MARK OPCODE FOUND MOVEM TEMP,PARRIG ;SAVE FOR PARSER UNFNDOP: POPJ P, ;RETURN, ANSWER IN B >;TENX ^CESSGO:MOVE TEMP,OPDUN ;SAVING OPDUN MOVEM TEMP,T.OPDUN SETZM OPDUN POPJ P, ^CESSOK: ;THIS EXEC TO DO THE ACCESS CONSTRUCT MOVE PNT, GENLEF+1 ;GET THE @E GENMOV ACCESS, GETD ;MAKE SURE THE EXPR IS AVAILABLE SETOM ACSWCH ;TELL THE CODVBL GUY NOT TO COMPLAIN ; PUSHJ P,REMOP ;DESTROY TEMPORARIES WITH ABANDON MOVE TEMP,T.OPDUN ;RESTORE OPDUN MOVEM TEMP,OPDUN POPJ P, ;;#UZ# JFR 8-22-75 DIDN'T HAVE THE DATA MACROS, DAMMIT DATA (RANDOM) T.OPDUN:0 ;PLACE TO PUT OPDUN ENDDATA ^CODID: SKIPN PNT,GENLEF+1 ;MUST BE DEFINED ERR ,1,FRGET MOVNI TBITS2,1 ;ASSUME NO OPCODE SEEN YET HLLOS TEMP,OPDUN ;MARK SOMETHING SEEN JUMPG TEMP,MAYBOP ;NO OPCODE SEEN, MIGHT BE CNST OPCODE NONOPC: SKIPN CODSEM ;CHECK TWO ADDRESS FIELDS SKIPE CODVAL ERR ,1 MOVEI TBITS2,0 ;OPCODE SEEN PREVIOUSLY MAYBOP: SETOM OPDUN ;NO MORE OPCODES ALLOWED PUSHJ P,GETAD TLNN TBITS,CNST ;CONSTANT? JRST CODVBL ; NO, MUST BE VARIABLE ADDR FIELD GENMOV (CONV,INSIST,INTEGR) ;GET INTEGER CONSTANT MOVE A,$VAL(PNT) JUMPL TBITS2,STROPC ;OPCODE CONSTANT (ASSUME SO, ANYWAY) MOVEM A,CODVAL ;NOT OPCODE, SAVE HERE JRST REMOP ;DON'T NEED CONST ANY MORE STROPC: ORM A,OPCOD ;NON-DESTRUCTIVE STORE JRST REMOP ;DON'T NEED SEMANTICS CODVBL: TLNN SBITS,FIXARR ;ACCEPT CNST-CNST-CNST ARRAY TLNN SBITS,ARTEMP!STTEMP ; AND VARIABLES JRST VBLOK SKIPN ACSWCH ;DON'T COMPLAIN IF ACCESS HAPPENED ERR ,1 VBLOK: MOVEM PNT,CODSEM ;SAVE SEMANTICS POPJ P, ^SETOP: HLLOS TEMP,OPDUN ;SET SOMETHING SEEN JUMPL TEMP,TWOOP ;TWO OPCODES SETOM OPDUN ;MARK OPCODE DONE MOVE A,GENLEF NOTENX< DPB A,[POINT 9,OPCOD,8] ;OPCOD POSITION >;NOTENX TENX< MOVEM A,OPCOD ;36-BIT OPCODE >; POPJ P, TWOOP: ERR ,1,FRGET ^CODIND: HLLOS OPDUN ;MARK SOMETHING SEEN MOVSI TEMP,20 ;INDIRECT BIT ORM TEMP,OPCOD ;PUT IN OPCOD WORD FRGET: POPJ P, ^CODREG: HLLOS OPDUN SKIPN PNT,GENLEF+1 ;MUST BE A CONSTANT ERR ,1,REMOP GENMOV (CONV,GETD!INSIST,INTEGR) TLNN TBITS,CNST ;MUST BE A CONSTANT ERR ,1,REMOP ;;#VN# JFR 10-30-75 AC FIELD IS SUPPOSED TO BE OR'ED, NOT DPB'ED ;; MOVE TEMP,$VAL(PNT) ;GET ITS VALUE ;; DPB TEMP,[POINT 4,OPCOD,12] ;DEPOSIT IN AC FIELD HRLZ TEMP,$VAL(PNT) ;VALUE IN LEFT HALF TLZ TEMP,777760 ;4 BITS ONLY LSH TEMP,5 ;OVER INTO AC FIELD ORM TEMP,OPCOD ;;#VN# ^ JRST REMOP ^CODX: HLLOS OPDUN SKIPN PNT,GENLEF+1 ;MUST BE A CONSTANT ERR ,1,REMOP GENMOV (CONV,GETD!INSIST,INTEGR) TLNN TBITS,CNST ERR ,1,REMOP ;;#VN# JFR 10-30-75 INDEX FIELD LIKEWISE SHOULD BE OR'ED ;; MOVE TEMP,$VAL(PNT) ;; DPB TEMP,[POINT 4,OPCOD,17] ;INDEX FIELD HRLZ TEMP,$VAL(PNT) TLZ TEMP,777760 ORM TEMP,OPCOD ;;#VN# ^ JRST REMOP ^CODLIT: HLLOS OPDUN SKIPN PNT,GENLEF+1 ERR ,1,REMOP MOVE TBITS,$TBITS(PNT) TLNN TBITS,CNST ERR ,1,REMOP SKIPN CODVAL ;CHECK FOR TWO ADDRESS FIELDS SKIPE CODSEM ERR ,1,REMOP CODBK: MOVEM PNT,CODSEM MOVSI TEMP,INLIN ;TURN SPECIAL SCANNING BIT ORM TEMP,SCNWRD ;BACK ON POPJ P, ^LITOFF: ;TURN OFF SPECIAL @ SCANNING BIT IN SCNWRD ; (CALLED WHEN SCANNING LITERALS, AND WHEN LEAVING A ; START!CODE BLOCK) MOVSI TEMP,INLIN ANDCAM TEMP,SCNWRD POPJ P, ^ERRCOL: ERR ,1 POPJ P, ^ERRCOM: ERR ,1 POPJ P, BEND INLINE SUBTTL COUNTER SYSTEM EXECS BEGIN COUNT DSCR KOUNT1,KOUNT2,KOUNT3,KOUNT4,KOUNT5 -- INSERT A COUNTER PRO KOUNT1 KOUNT2 KOUNT3 KOUNT4 KOUNT5 DES These exec routines insert a counter into the code and a marker into the output listing. They are NO-OP's unless the /K switch is specified. As a listing file is necessary for /K, it is not necessary to check SCANWD for listing. KOUNT2 will someday do the right thing for multiple labels. KOUNT3 , KOUNT4, and KOUNT5 insert a different marker for counters in expressions. The multiplicity of routines for expression counters comes from the necessity of having the counter immediately after the reserved word in order for the analysis routine to work right.  ^KOUNT6: SKIPA C,[","] ;SHOULD FOLLOW "," ^KOUNT5: MOVEI C,"(" ;SHOULD FOLLOW "(" JRST KOUNT4+1 ^KOUNT3: SKIPA C,["N"] ;SHOULD FOLLOW "THEN" ^KOUNT4: MOVEI C,"E" ;SHOULD FOLLOW "ELSE" MOVEI B,3 ;MARKER IS BETA ('03) MOVEI D,LSTOU1 ;USE THIS LIST ROUTINE JRST KOUNT1+2 ^KOUNT2: ;EVENTUALLY, CHECK FOR MULTIPLE LABELS ^KOUNT1: MOVEI B,2 ;MARKER IS ALPHA ('02) MOVEI D,LSTOUT ;USE THIS ROUTINE ;;%##% JFR 4-18-76 BAIL< SKIPE BPNXTC ;IF COORDINATE HAS BEEN MARKED PUSHJ P,BCROUT ;THEN PUT IT OUT >;BAIL ;;%##% ^ SKIPN KOUNT ;ARE WE INSERTING COUNTERS POPJ P, ;NO MOVE A,[AOS 0] PUSHJ P,CODOUT ;PUT THE ADD INSTR INTO THE CODE AOS KCOUNT ;COUNT THE COUNTERS MOVE A,PCNT SUBI A,1 QPUSH (KPDP,) ;SAVE ADDRESS OF AOS MOVEI A,177 ;PUT A MARKER INTO PUSHJ P,(D) ; THE LIST FILE MOVEI C,177 ;NEEDED IN CASE WE'RE CALLING LSTOU1 MOVE A,B ;GET THE CHARACTER FOR THE MARK PUSHJ P,(D) POPJ P, BEND COUNT SUBTTL ARRAY DECLARATION AND INDEXING EXECS