! File: DECLAR.BLI ! ! This work was supported by the Advanced Research ! Projects Agency of the Office of the Secretary of ! Defense (F44620-73-C-0074) and is monitored by the ! Air Force Office of Scientific Research. ! Module DECLAR= Begin ! DECLAR MODULE ! ------------- ! ! D. WILE ! MODIFIED BY: ! R. JOHNSSON ! P. KNUEVEN ! ! THIS MODULE PROCESSES DECLARATIONS. ! Require 'Bliss'; Own STE : Ref ST, ptr_actuals : Ref Vector, MACRDEF : Ref ST, DECLSIZE : Integer, LNKGLX : Ref ST, STELIST : Ref ST, STELAST : Ref ST, PLLBRAC : Integer, STRSTE : Ref ST, OFLAGS : Integer, OTYPE : Integer, OFUN : Integer, OEQL : Integer, PLHEAD : Vector[8,Byte] Initial('P$AAA'); Literal SWSWL=20, !HIGHEST SWITCH INDEX VALID IN SWITCHES DECL. ALLSW=28; ! ' ' ' ' ' MODULE HEAD ! THE FOLLOWING IS A LIST OF SWITCHES FOR THE BLISS COMPILER. ! IT IS A PLIT WHICH IS SEARCHED AS A VECTOR. ! ! THIS DECLARATION IS SET UP AS FOLLOWS: ! ! FOR EACH ALLOWABLE SWITCH NAME, ONE OF THE ABOVE ! MACROS IS INVOKED WITH THE FIRST FIVE (5) CHARACTERS ! OF THAT SWITCH NAME AS ITS ARGUMENT. THE REMAINING ! CHARACTERS OF THE SWITCH NAME, IF ANY, FOLLOW AS A COMMENT. Bind SWTBL = Uplit Long (AZ( 'EXPAND', 'NOEXPAND', 'LIST', 'NOLIST', 'ERRS', 'NOERRS', 'OPTIMIZE', 'NOOPTIMIZE', 'UNAMES', 'NOUNAMES', 'FINAL', 'NOFINAL', 'SAFE', 'UNSAFE', 'ZIP', 'UNZIP', 'DEBUG', 'NODEBUG', 'PIC', 'NOPIC', ! END OF SWITCHES VALID IN BOTH MODULE HEAD AND SWITCHES DECLARATION. ! MODIFY SWSWL IF THE NUMBER OF SWITCHES ABOVE THIS CHANGES. ! THE FOLLOWING SWITCHES ARE VALID ONLY IN THE MODULE HEAD. 'SEGMENT', 'NOSEGMENT', 'START', 'STACK', 'MAIN', 'RESERVE', 'IDENT', 'SYNTAX')) : Vector[,Long]; ! KEYWORD TABLE FOR CSECT/PSECT PROCESSING Bind KWTBL = Plit Long ( AZ( 'CODE', 'DEBUG', 'GLOBAL', 'OWN', 'PLIT')) : Vector[,Long]; Forward Routine ERRDECL : Novalue, DCLARE : Novalue, DECLARESYM, DEFOG, DEFGLO, DEFASYM : Novalue, DEFMAP : Novalue, INITEQ, OWNEQ, GLOBALEQ, MAPPURGE, SYMPURGE, GETLNKG : Novalue, SFORWARD : Novalue, SUNDECLARE : Novalue, STARTLNKG, STARTNAME, MAYBEDECLARE, STARTCOL, CONTIDLIST, MAPONE, ENDIDBATCH, WHICHBIND, BINDEQ, GLBINDEQ, REGEQ, DOEQL, DOSIZE, GROMLIST : Novalue, PGLOBAL, POWN, PSTACKLOCAL, PLOCAL, PEXTERNAL, PLABEL, PREGISTER, PBIND, PGLOBBIND, PROCPARMS, GLOBROUT : Novalue, SLOCAL : Novalue, SSTACKLOCAL : Novalue, SOWN : Novalue, SGLOBAL : Novalue, SEXTERNAL : Novalue, SDCLLABEL : Novalue, SREGISTER : Novalue, SBIND : Novalue, SGLOBBIND : Novalue, SROUTINE : Novalue, SMAP : Novalue, SSETSIZE : Novalue, SBYTE : Novalue, SWORD : Novalue, INCRDECRREG, SSWITCHES : Novalue, DOMODULE : Novalue, GETCONS, GETSTRING, SWITCHER, SIDENT, SSTACK, SMAIN, SSTART, SRESERVE, PPARAM, SSTRUCTURE : Novalue, SMACRO : Novalue, GETSTRING2, SCSECT : Novalue, SLNKGDECL : Novalue, SPLIT : Novalue, SPLITB, PLITARG, TUPLEITEM, LSORLE, LEXTOP, SREQUIRE : Novalue; Bind DECLARATORS = Uplit Long ( 0, !0 SBYTE, !1 SOWN, !2 SGLOBAL, !3 SEXTERNAL, !4 SROUTINE, !5 SSTRUCTURE, !6 SMAP, !7 SFORWARD, !8 SBIND, !9 SMACRO, !10 SUNDECLARE, !11 SDCLLABEL, !12 SWORD, !13 SSWITCHES, !14 SLOCAL, !15 SREGISTER, !16 SENABLE, !17 SREQUIRE, !18 SCSECT, !19 SSTACKLOCAL, !20 SLNKGDECL, !21 SCSECT !22 - PSECTS HANDLED BY CSECT ROUTINE ) : Vector[,Long]; Macro ALLIGN(TABLE,NBYTE)=If .TABLE And Not NBYTE Then TABLE = .TABLE+1 %, NEXTINTAB(TABLE,S)=(S[gt_disp] = .TABLE; TABLE = .TABLE+.S[st_var_size]) %, BYTES(S)=(.S[gt_len]/8) %; Macro ERROR(A,B,C,D)=ERRORR(D,C,B,A) %, SXCTDECL=(pos_open = .pos_del;bliss(.DECLARATORS[.DEL])) %, XCTDECL= Begin If .SYM Neq TK_EMPTY Then Begin SYM = TK_EMPTY; ERROR(.pos_open,.pos_sym,.LASTEND,DECLSYMERR) End Else Begin SXCTDECL; If .DEL Neq TK_SEMICOLON Then ERROR(.pos_open,.pos_del,.LASTEND,DCLDELERR) Else RUND(QL_LEXEME) End End %, DECF(S,TP)= Begin If Not DECLARESYM(S,TP,1) Then Return; S[gt_pos] = 0; S[gt_len] = 16 End %, CKFORWD(S,RTYPE)= Begin S = .SYM[nt_symb]; If .S Neq 0 And .S[st_scope] Eql .BLOCKLEVEL And .S[gt_type] Eql S_FORWARD Then Begin S[gt_type] = RTYPE; S[st_v_debug] = .swit_debug End Else DECF(S,RTYPE) End %, FBIT(BITNUM)=BITNUM,1,0 %, MUSTDECLARE =FBIT(0) %, !DECLARATION OTHER THAN MAP. MUSTMAP =FBIT(1) %, !MUST BE MAPPED. ISSBSLEX =FBIT(2) %, !HAS A SIZE LEXEME STREAM. TEMPF =FBIT(3) %, !TEMPORARY BOOLEAN. WASANEQUAL =FBIT(4) %, !EQUAL FOUND FOLLOWING THE !INCARNATION ACTUALS. LITRESULT=(.SYM Eql T_LITERAL) %, RULITEXP(LOCALSAV,LOCINFO)=(RUND(QL_LEXEME); LITEXP(LOCALSAV,LOCINFO)) %, LITEXP(LOCALSAV,LOCINFO)= Begin LOCALSAV = LOCINFO; EXPRESSION(); SYM = BINDBIND(.SYM); If Not LITRESULT Then Begin WARNEM(.LOCALSAV,ERMBADEXP); SYM = ONE End End %; Global Routine ERRDECL : Novalue = Begin SXCTDECL ! FOR ERROR HANDLING--SEE RUNC IN SYNTAX End; Global Routine DCLARE : Novalue = Begin Local SAVEL : Integer; ! note that we are inside a declaration and set the default allocation ! unit to a word. also set up for error recovery and raise the scope level INDCL; DECLSIZE = 2; NEWLASTEND(PSSEM); BLOCKLEVEL = .BLOCKLEVEL+1; ! loop for all declarations While .DEL Eql DCLRTR Do XCTDECL; ! round up the next stack address If .NEXTLOCAL Then NEXTLOCAL = .NEXTLOCAL+1; ! restore the previous state and note the last good position RESINDECL; RESLASTEND; pos_good = .pos_del End; !I. GENERAL: ! ! 1. THIS ROUTINE DECLARES A SYMBOL IN 'SYM'. ! ! 2. PARAMETERS: ! ! A. WHERE - A POINTER TO A LOCATION WHERE THE ! SYMBOL TABLE INDEX OF THE SYMBOL ! DECLARED IN 'SYM' SHOULD BE PUT. ! ! B. TYPE - THE TYPE OF THE SYMBOL TO BE DECLARED ! ! C. ERRHURTS - A BOOLEAN THAT DETERMINES THE TYPE ! OF ERROR RECOVERY TO BE ATTEMPTED. ! !II. SPECIFIC: ! ! 1. * ! ! A. FIRST EXAMINE THE LEXEME IN SYM. ! 1. IF IT IS NOT A NAME TABLE ENTRY, GIVE ! EITHER AN ERROR OR A WARNING MESSAGE, ! DEPENDING ON THE SETTING OF 'ERRHURTS'. ! ! 2. PICK UP THE SYMBOL TABLE ENTRY MOST ! RECENTLY ATTACHED TO THIS NAME TABLE ! ENTRY. ! ! B. IF THE ENTRY IS UNDECLARED, OR FROM AN OUTER ! BLOCK, THEN: ! 1. DECLARE THE SYMBOL, AND ENTER ITS NEW ! TYPE IN A NEW SYMBOL TABLE ENTRY FOR ! THIS BLOCK. ! ! ! 2. PUT IT WHERE THE CALLER WANTS IT, ! AND CORRECT THE FUTURE SYMBOL LEXEME. ! ! C. OTHERWISE, WE HAVE ALREADY DECLARED IT IN ! THIS BLOCK, AND THAT IS AN ERROR. Routine DECLARESYM(WHERE,TYPE : Integer,ERRHURTS : Boolean) = Begin Local S : Ref ST, MSGTYPE, ERRLOC; ! assume an error of a missing name MSGTYPE = ERNOSYM; ERRLOC = .pos_sym; ! if no symbol then check to see if there was an attempt to declare a ! reserved word If .SYM Eql TK_EMPTY Then Begin ERRLOC = .pos_del; If .RESWD Then Begin RUNDE(); MSGTYPE = ERDCLRESWD End End; ! the quote level to get this symbol was Q_NAME. if it was bound then ! that probably means the user used %UNQUOTE wrongly. If .SYM Eql T_SYMBOL Then Begin WARNEM(.pos_open,.pos_sym,ERNOSYM); SYM = .SYM[st_name] End ! make sure there is a symbol to declare Else If .SYM Neq T_NAME Then Begin If .ERRHURTS Then ERROR(.pos_open,.ERRLOC,.LASTEND,.MSGTYPE) Else WARNEM(.pos_open,.ERRLOC,.MSGTYPE); Return FALSE End; ! if inside a structure expansion then hide any previous symbol. If .STRUEXPAND Then STINSERT(.SYM,S_UNDECLARE,0); ! check for a previous symbol at the same block level. S = .SYM[nt_symb]; If .S[gt_type] Neq S_UNDECLARE And .S[st_scope] Geq .BLOCKLEVEL Then Begin ERRINFO[0] = .S; WARNEM(.pos_sym,WASMPREV) End; ! enter the new symbol into the symbol table .WHERE = STINSERT(.SYM,.TYPE,0); Return TRUE End; ! define OWN/GLOBAL symbols Routine DEFOG(TABLE,S : Ref ST,REQIN : Boolean,RELIN : Boolean,INIT : Ref CELL) = Begin ! make sure the table is aligned properly for this symbol's allocation unit ALLIGN(.TABLE,BYTES(S)); ! if initialized then note it and save the initialization info. also note ! whether this is the first instance of this info. symbols grouped together ! share the same initialization info. If .REQIN Then Begin S[st_v_init] = TRUE; S[st_v_release_init] = .RELIN; S[st_var_init] = .INIT End; S[gt_reg] = PC; ! if a plit, allocate a word for the count If .S[st_v_plit] And .S[st_v_counted] Then .TABLE = ..TABLE + WRDSZ/8; ! allocate an address in the psect NEXTINTAB(.TABLE,S); ! allocate use/change lists INITSYMLSTS(.S); Return FALSE End; ! define a global symbol Routine DEFGLO(S : Ref ST,REQIN : Boolean,RELIN : Boolean,INIT : Ref CELL) = Begin DEFOG(NEXTGLOBAL,.S,.REQIN,.RELIN,.INIT); S[gt_mode] = ABSOLUTE; Return FALSE End; ! define a symbol's allocation Global Routine DEFASYM(S : Ref ST,NOBYTES : Integer,POS : Integer,SIZ : Integer) : Novalue = Begin S[st_var_size] = .NOBYTES; S[gt_pos] = .POS; S[gt_len] = .SIZ; S[st_var_linkage] = .LNKGLX End; Global Routine DEFMAP(S : Ref ST) : Novalue = Begin S[st_v_no_acts] = TRUE; S[st_var_actuals] = .sym_vector End; Routine INITEQ = Begin Local PLITP,ERR, SIZ; ERR = .pos_del; OLDDELI = %o'126'; ! 'PLIT' SIGNAL TO DETBRACKET SIZ = SPLITB(PLITP) * WRDSZ/8; If .SIZ Gtr .unit_size Then Begin If Not .NOTREE Then WARNEM(.ERR,ERISEDS); unit_size = .SIZ End; SYM = .PLITP; Return FALSE End; Routine OWNEQ = Begin Return INITEQ() End; Routine GLOBALEQ = Begin Return INITEQ() End; Routine MAPPURGE(S : Ref ST)= Begin Local STREAM : Ref Vector; If .S[st_var_actuals] Eql 0 Or .S[st_v_no_acts] Or Not .S[st_v_release_acts] Then Return FALSE; STREAM = .S[st_var_actuals]; STREAM[STRUCF] = 0; STRMRELEASE(.STREAM); Return TRUE End; ! SYMPURGE RETURNS TRUE IF THE SYMBOL MAY BE PURGED. IN ! ADDITION IT RELEASES ALL FIELDS (STREAMS AND ! TREES ASSOCIATED WITH THE FIELDS WITHIN THE SYMBOL. Global Routine SYMPURGE(S : Ref ST) = Begin Selectone .S[gt_type] Of Set [S_UNDECLARE]: Return 1; [S_MACRO]: Begin STRMRELEASE(.S[st_mac_body]); Return 1 End; [S_STRUCTURE]: Begin STRMRELEASE(.S[st_str_body]); If .S[st_str_alloc] Neqa 0 Then STRMRELEASE(.S[st_str_alloc]); Return 1 End; [S_FORWARD]: Begin ERRINFO[0] = .S; WARNEM(0,ERMRD); Return 1 End Tes; ! MAPPABLE TYPES ONLY PAST HERE If Not ISSTVAR(S) Then Return 1; MAPPURGE(.S); If .S[gt_type] Eql S_GLOBAL Or .S[gt_type] Eql S_OWN Then If .S[st_v_init] And .S[st_v_release_init] Then ERASEDET(.S[st_var_init]); Return 2 End; ! ! CALLED BY SFORWARD, GLOBROUT, AND SROUTINE ! PARSES THE LINKAGE NAME OF THE ROUTINE ! Routine GETLNKG(LOC) : Novalue = Begin Local LNKGNM : Ref ST; LNKGNM = .sym_bliss; If .DEL Eql TK_ERROR Then Begin LNKGNM = .SYM[nt_symb]; If .LNKGNM[gt_type] Neq S_LINKAGE Then Begin WARNEM(.pos_sym,WAMSPLNKG); LNKGNM = .sym_bliss End; RUND(QL_NAME) End; .LOC = .LNKGNM End; ! !SYNTAX: FORWARD ,,..., ! ! ::=/(<#PARAMETERS>) ! !I. GENERAL: ! ! 1. THIS ROUTINE DECLARES AS FORWARD WITHIN THE BLOCK ! OPEN AT THE TIME OF DECLARATION. ! ! 2. THIS MEANS THAT THE ROUTINE WILL BE FOUND, AND ! DECLARED LATER WITHIN THIS SAME BLOCK; ! !II. SPECIFIC: ! ! 1. * ! ! A. IT DOES EACH OF THE FOLLOWING THINGS TO ! DECLARE A FORWARD NAME UNTIL IT COMES TO ! A ';'. ! ! 1. DECLARE THE NAME IN 'SYM' AS OF ! TYPE FORWARD. ! ! 2. NEXT, IF WE SEE AN OPEN PARENTHESIS, ! ('('),THEN: ! ! A. PROCESS THE EXPRESSION WITHIN ! THE PARENTHESIS PAIR, AND ! MAKE SURE IT IS A LITERAL. ! ! B. IF WE DON'T NOW SEE A ! CLOSE PARENTHESIS ! AND AND EMPTY FUTURE SYMBOL, ! IE, THE WINDOW SHOULD BE: ! ! (XXX,')',,',') ! ! THEN THERE IS AN ERROR. ! ! C. SAVE THE RESULTING LITERAL, ! AND MOVE THE WINDOW. ! ! 3. FINALLY, ADD THE NUMBER OF PARAMETERS ! FOR THE ROUTINE TO ITS SYMBOL TABLE ! ENTRY. ! ! 4. GENERATE INFORMATION FOR THE ROUTINE. ! ! 5. WE SHOULD HAVE A COMMA NEXT, OR A ';' Routine SFORWARD : Novalue = Begin Local SFSYMCHK, SAVSYM, S : Ref ST, LNKGNM : Ref ST; Do Begin RUND(QL_NAME); GETLNKG(LNKGNM); If DECLARESYM(S,S_FORWARD,0) Then Begin If .DEL Eql TK_CALL Then Begin RULITEXP(SFSYMCHK,.pos_sym); If .DEL Neq TK_RPAREN Then Return ERROR(.pos_open,.pos_del,.LASTEND,ERSYMNPRD); SAVSYM = .SYM; RUND(QL_LEXEME); If .SYM Neq TK_EMPTY Then Return ERROR(.pos_open,.pos_del,.LASTEND,ERSYMNPRD) End Else SAVSYM = 0; DEFMAP(.S); S[st_var_linkage] = .LNKGNM; S[gt_pos] = 0; S[gt_len] = 16; S[gt_reg] = PC; S[gt_mode] = (If .swit_pic Then RELATIVE Else ABSOLUTE); End End While .DEL Eql TK_COMMA End; Routine SUNDECLARE : Novalue = Begin Do Begin RUND(QL_NAME); STINSERT(.SYM,S_UNDECLARE,0) End While .DEL Eql TK_COMMA End; Routine STARTLNKG= Begin Local S : Ref ST; Label aaa; LNKGLX = .sym_bliss; If .DEL Eql TK_ERROR Then aaa: Begin Macro FORGET(WARNTYPE) = Begin WARNEM(.pos_sym,WARNTYPE); RUND(QL_NAME); Leave aaa End %; If .SYM Eql T_NAME Then SYM = FASTLEXOUT(T_SYMBOL,.NT[.SYM,nt_symb]) Else If .SYM Neq T_SYMBOL Then FORGET(WAINVSTRUC); S = .SYM; If .S Eql .sym_trap Then FORGET(WATRAPLNKG); If .S[gt_type] Neq S_LINKAGE Then Return 0; LNKGLX = .S; RUND(QL_NAME) End; Return 0 End; !I. GENERAL: ! ! 1.THIS ROUTINE SETS UP A STRUCTURE SYMBOL TABLE ENTRY ! FOR THE SYMBOLS FOLLOWING IT, IF THE STRUCTURE IS ! SPECIFIED. ! ! 2. WE THEN SET FIELDS RELEVANT TO THE STRUCTURE, ONLY ! IF THE SYMBOLS FOLLOWING IN THIS DECLARATION ARE ! TO BE MAPPED. ! !II. SPECIFIC: ! ! 1. * ! ! A. IF '.DEL' IS AN ERROR LEXEME THEN WE ! HAVE: ! WITH NO INTERVENING DELIMITER, AND THUS ! SPECIFIES A STRUCTURE MAPPING. ! ! B. WE HAVE ERRORS NOW, IF: ! ! 1. THE SYMBOL TABLE ENTRY FOR THE ! STRUCTURE IS OF AN UNDECLARED TYPE. ! ! 2. THE SYMBOL IS NOT OF TYPE STRUCTURE. ! ! C. IF EVERYTHING ELSE IS OK, THEN WE HAVE A ! STRUCTURE, SO WE SET THE 'MUSTMAP' FIELD ! OF THE FLAGS 'OFLAGS', SINCE WE MUST THEN ! MAP THIS STRUCTURE ONTO ALL FOLLOWING ! IDENTIFIERS IN THIS FIELD. ! ! D. OTHERWISE,, IF WE DON'T EXPLICITLY HAVE A STRUCTURE, ! THEN THE STRUCTURE SYMBOL TABLE INDEX IS SET ! TO THE VECTOR DEFAULT INDEX, AND WE NEED NOT ! MAP AT THIS POINT. THE REASON THAT WE DO ! SET THE INDEX THOUGH IS THAT WE MAY FIND ! LATER THAT WE INDEED DO NEED TO MAP, AND WE ! WILL THEN HAVE EVERYTHING SET UP. ! E. NEXT WE SEE IF THE FOLLOWING ID'S NEED TO BE ! MAPPED WHETHER OR NOT WE SAW A STRUCTURE. ! THEY NEED TO BE MAPPED IN THE FOLLOWING ! CASES: ! ! 1. A STRUCTURE WAS SPECIFIED. ! ! 2. WE SEE '['. ! ! 3. WE SEE ':'. ! ! 4. THE IDENTIFIERS FOLLOWING ARE ! NOT TO BE DECLARED. ! ! 2. * ! ! A. THEN, IF WE DO NEED TO MAP, THEN WE DO THE ! FOLLOWING: ! ! 1. SET THE FLAG FOR THE LEXEME STREAM ! TYPE. ! ! 2. SET THE LEXEME STREAM STRUCTURE INDEX. ! ! 3. SET THE INCARNATION ACTUALS CELL BLOCK ! SIZE, AND THE NUMBER OF EXPECTED ! INCARNATION ACTUALS. NOTE THAT THE ! NUMBER OF EXPECTED INCARNATION ! ACTUALS IS OBTAINED FROM THE ! STRUCTURE SYMBOL TABLE ENTRY. Routine STARTNAME = Begin Local S : Ref ST; Label aaa; ptr_actuals = 0; STRSTE = .sym_vector; If .DEL Eql TK_ERROR Then aaa: Begin Macro FORGET(WARNTYPE) = Begin WARNEM(.pos_sym,WARNTYPE); RUND(QL_NAME); Leave aaa End %; If .SYM Eql T_NAME Then SYM = .NT[.SYM,nt_symb] Else If .SYM Neq T_SYMBOL Then FORGET(WAINVSTRUC); S = .SYM; If .S[gt_type] Neq S_STRUCTURE Then FORGET(WASMNOTSTR); RUND(QL_NAME); STRSTE = .S End; Return 0 End; !I. GENERAL: ! ! 1. THIS ROUTINE DECLARES THE SYMBOL IN 'SYM' IF IT ! SHOULD BE, (IE IF OFLAGS[MUSTDECLARE] IS ON). ! ! 2. RETURNS: ! ! A. THIS ROUTINE RETURNS A 1 IF THERE WERE ! ANY ERRORS FOUND DURING DECLARATION. Routine MAYBEDECLARE(ERRHURTS : Boolean) = Begin If .OFLAGS Then Return Not DECLARESYM(STE,.OTYPE,.ERRHURTS); STE = .SYM[nt_symb]; Return FALSE End; !I. GENERAL: ! ! 1. THIS ROUTINE TAKES THE SYMBOL IN 'SYM', DECLARES ! IT IF NECESSARY, AND PUTS IT AS THE FIRST ELEMENT ! ON THE SYMBOL TABLE LIST. ! ! 2. THIS SYMBOL TABLE LIST IS MADE SINCE WE CAN HAVE ! THINGS OF THE FORM: ! ! :...:[,...,]:... Routine STARTCOL = Begin If MAYBEDECLARE(TRUE) Then Return TRUE; STELAST = STELIST = GETSPACE(SZ_STELIST); STELIST[ste_symb] = .STE; STELIST[ste_pos] = .pos_sym; Return FALSE End; !I. GENERAL: ! ! 1. THIS ROUTINE SIMPLY CONTINUES DECLARING SYMBOLS ! IN 'SYM'. ! ! 2. WINDOW IN: ! ! A. ( , ':' ) ! ! 3. WINDOW OUT: ! ! A. ( , ':'/'['/','/';' ) Routine CONTIDLIST = Begin Local SAVSTE : Ref ST; RUND(QL_NAME); If MAYBEDECLARE(FALSE) Then Return TRUE; SAVSTE = .STELAST; SAVSTE[ste_next] = STELAST = GETSPACE(SZ_STELIST); STELAST[ste_symb] = .STE; STELAST[ste_pos] = .pos_sym; Return FALSE End; Routine MAPONE(POS,FIRST)= Begin Local STEE; If .OTYPE Eql 0 Then Begin If Not ISEXP(STE) Then Begin WARNEM(.POS,WACANTMAP); Return 0 End; If .STE[st_scope] Eql .BLOCKLEVEL Then MAPPURGE(.STE) Else Begin STEE = .STE; SYM = LEXOUT(T_NAME,.STE[st_name]); DECLARESYM(STE,S_BIND,0); DEFASYM(.STE,0,0,8*.DECLSIZE); STE[st_bind_data] = BINDBIND(LEXOUT(T_SYMBOL,.STEE)) End End; If .ptr_actuals Neqa 0 Then Begin If STE[st_v_release_acts] = .FIRST Then ptr_actuals[STRUCF] = .STRSTE; STE[st_var_actuals] = .ptr_actuals End Else Begin STE[st_v_no_acts] = TRUE; STE[st_var_actuals] = .STRSTE End; Return 0 End; Routine ENDIDBATCH= Begin Local TEMP : Ref ST, FIRSTACT : Boolean; FIRSTACT = TRUE; Do Begin STE = .STELIST[ste_symb]; If MAPONE(.STELIST[ste_pos],.FIRSTACT) Then Return 1; If .OFLAGS Then Begin DEFASYM(.STE,.unit_size,0,8*.DECLSIZE); If Bliss(.OFUN,.FIRSTACT,.unit_size,.STE) Then Return TRUE End; FIRSTACT = FALSE; TEMP = .STELIST; STELIST = .TEMP[ste_next]; RELEASESPACE(.TEMP,SZ_STELIST) End While .TEMP Neq .STELAST; Return 0 End; !I. GENERAL: ! ! 1. THIS ROUTINE DETERMINES WHAT TYPE OF BIND WE MUST ! DO, AND PASSES ITS FINDINGS TO ITS CALLER AS A ! RETURN VALUE. ! ! 2. RETURNS: ! ! A. 0 - CODE MUST BE GENERATED FOR THIS ! BIND. ! ! B. 1 - THE BIND IS TO A LITERAL. ! ! C. 2 - GENERAL ADDRESS BIND, BUT NO CODE. Routine WHICHBIND= Begin Local TEMP, L : Ref GT; EXPRESSION(); SYM = BINDBIND(.SYM); ! GET RID OF <0,0> AND <0,8> BEFORE CHECKONELOCAL DOES SO If .SYM Eql T_NODE Then Begin If .SYM[gt_code] Neq OP_POINTER Or .SYM[gt_arg2] Neq ZERO Then Begin DYNBIND(); Return 0 End; L = .SYM[gt_arg3]; If .L Mod 8 Neq 0 Then Begin DYNBIND(); Return 0 End; TEMP=.SYM; SYM = .SYM[gt_arg1]; PDETACH(.TEMP); RELEASESPACE(.TEMP,SZ_NODE+3); If .SYM Eql T_NODE Then Begin DYNBIND(); Return 0 End End; If LITRESULT Then Return 1 Else Return 2 End; Routine BINDEQ= Begin RUND(QL_LEXEME); WHICHBIND(); Return 0 End; Routine GLBINDEQ= Begin RUND(QL_LEXEME); Case WHICHBIND() From 0 To 2 Of Set [0]: Begin WARNEM(.pos_sym,ERSMPLNLO); SYM = ZERO End; [1]: 0; [2]: Begin If .SYM Neq T_SYMBOL Or Not LOADCONST(SYM) Then Begin WARNEM(.pos_sym,ERSMPLNLO); SYM = ZERO End End Tes; Return 0 End; !I. GENERAL: ! ! 1. THIS ROUTINE PROCESSES AN '=' IN A REGISTER ! DECLARATION. ! !II. SPECIFIC: ! ! 1. * ! ! A. EVALUATE AN EXPRESSION WHOSE RESULT SHOULD ! BE A LITERAL. ! ! B. IF THE RESULT IS A LITERAL, THEN CHECK THAT ! IT IS WITHIN LIMITS FOR A REGISTER ! DECLARATION. ! ! C. IF EVERYTHING ELSE SO FAR IS OK, THEN SEE IF ! THE REGISTER IS IN USE FOR ANYTHING ELSE AT ! THIS TIME, AND IF IT IS, THEN GIVE A WARNING. Routine REGEQ= Begin Local SAVSYMPOS, LTRES; Literal LOWREG=0, HIGHREG=5; RUND(QL_LEXEME); LITEXP(SAVSYMPOS,.pos_sym); LTRES = .SYM; If (.LTRES Gtr HIGHREG) Or (.LTRES Lss LOWREG) Then Begin WARNEM(.SAVSYMPOS,ERSMNDEC); SYM = ONE End; Return 0 End; !I. GENERAL: ! ! 1. THIS ROUTINE HANDLES THE GENERAL CASE OF AN EQUAL ! SIGN ('=') AFTER AN IDENTIFIER IN A DECLARATION. ! ! 2. RETURNS: ! ! A. 1 - IF ANY ERRORS WERE FOUND. AN ERROR OCCURS ! IF: ! ! 1. NO EQUAL SIGN IS FOUND, AND WE ! REQUIRE ONE. ! ! 2. THE SPECIFIC ROUTINE WHICH PROCESSES ! EQUAL SIGNS FOR THE TYPE OF ! DECLARATION WE ARE NOW PROCESSING ! FINDS ANY ERRORS. ! !II. SPECIFIC: ! ! 1. * ! ! A. IF A PROCESSING ROUTINE WAS SPECIFIED, AND ! AN EQUAL SIGN WAS FOUND (IN 'SYM'), THEN ! MOVE THE WINDOW SO IT IS AT THE ! BEGILNING OF THE EXPRESSION FOLLOWING THE ! EQUAL SIGN. ! ! B. THERE ARE FOUR (4) RETURN CASES. ! ! 1. NO EQUAL SEEN, NONE REQUIRED, ALL OK. ! ! 2. NO EQUAL, BUT ONE IS REQUIRED, ! ERROR. ! ! 3. EQUAL SEEN, AND NOT REQUIRED. PROCESS ! IT, AND RETURN IN THE SAME STATE AS ! THE PROCESSING ROUTINE EXITED. ! ! 4. EQUAL SEEN, AND IT WAS REQUIRED. ! AGAIN PROCESS IT AND RETURN IN THE ! SAME STATE AS THE PROCESSING ROUTINE ! EXITED. Routine DOEQL= Begin If .DEL Eql TK_EQUAL Then Begin OFLAGS = TRUE; If .OEQL Eql 0 Then Begin WARNEM(.pos_del,WANOEQL); Return INITEQ() End End Else OFLAGS = FALSE; Case .OFLAGS*2+(.OEQL Lss 0) From 0 To 3 Of Set [0]: Return FALSE; [1]: Begin ERROR(.pos_open,.pos_del,.LASTEND,ERSYMEQ); Return TRUE End; [2]: Return Bliss(.OEQL,.unit_size); [3]: Return Bliss(-.OEQL,.unit_size) Tes End; Routine DOSIZE= Begin Local NOBRAC, NSTART,SAVMNACTS,SAVDEL; unit_size = .DECLSIZE; If .DEL Eql TK_COLON Then Return FALSE; NSTART = .pos_del; ptr_actuals = GETSPACE(.STRSTE[st_str_argc]+4); ptr_actuals[strm_size] = .STRSTE[st_str_argc]+2; If .DEL Eql TK_LBRACKET Then Begin If .OTYPE Eql S_LABEL Then WARNEM(.pos_del,LSIZERR); SAVMNACTS = .MANYACTS; MANYACTS = FALSE; STRUPICKOFF(TK_RBRACKET,ptr_actuals[3],.ptr_actuals[strm_size]-1,ONE,TRUE); MANYACTS = .SAVMNACTS; NOBRAC = FALSE End Else Begin Incr I From 2 To .ptr_actuals[strm_size] Do ptr_actuals[.I] = ONE; NOBRAC = TRUE End; ptr_actuals[2] = LITLEXEME(.DECLSIZE); If .STRSTE[st_str_alloc] Neq 0 Then Begin If .NOBRAC Then SAVDEL = .DEL; ESTRU(.STRSTE[st_str_alloc],ptr_actuals[-1],.STRSTE,.NOBRAC); If .NOBRAC Then DEL = .SAVDEL; SYM = BINDBIND(.SYM); If Not LITRESULT Then Begin WARNEM(.NSTART,ERMBADEXP); SYM = ONE End; unit_size = .SYM End Else If Not .NOBRAC Then RUNDE(); Return FALSE End; ! !SYNTAX: ,..., ! ! ::= ...: ! ::=/ ! ::=:...: ! ::=/[,...,] ! ::=/ = ! !I. GENERAL: ! ! 1. THIS ROUTINE HANDLES THE GENERAL PROCESSING OF ! DECLARATIONS. ! ! 2. MACROS: ! ! A. CHECK(ROUTNAME) - 'ROUTNAME' MUST BE THE ! NAME OF A ROUTINE WHICH RETURNS A 1 ! IF ANY ERRORS WERE FOUND. THIS MACRO ! SIMPLY SERVES TO CALL THIS ROUTINE, AND ! RETURN IF ANY ERRORS WERE FOUND. ! ! B. OTHERCHECKS - THIS MACRO STARTS THE PROCESSING ! OF A FIELD FOLLOWING THE ! OPTIONAL STRUCTURE, UP TO THE ! FIRST COMMA. IT WORKS AS ! FOLLOWS. IT FIRST PROCESSES ! THE FIRST NAME IN A POSSIBLE ! STRING OF AN ARBITRARY ! NUMBER, LIKE - X:Y:Z:... ! THEN IT PROCESSES ALL OTHERS ! WHILE THE DELIMITER FOLLOWING ! EACH IS A COLON (':'), IE ! UNTIL IT COMES TO '[' OR '=' ! AS IN X:Y:Z[10] OR X:Y:Z=20 ! IT THEN TRIES TO PROCESS AN ! OPTIONAL SIZE FIELD, AND THEN ! AN '=' (BIND). FINALLY, IT ! CALLS 'ENDIDBATCH' TO ANY ! LAST NECESSARY THINGS IN THE ! DECLARATION OF IDENTIFIERS SO ! FAR FOUND. ! !II. SPECIFIC: ! ! 1. * ! ! A. FIRST PUT ALL PARAMETERS INTO GLOBALS FOR ! OTHER PROCESSING ROUTINES TO USE. ! ! B. TO PROCESS A FIELD OF DECLARATIONS,(IE ! BETWEEN COMMAS), WE MUST DO THE FOLLOWING ! THINGS: ! ! 1. FIRST CHECK IF THERE IS A STRUCTURE ! NAME, AND IF THERE IS, THEN DO THE ! APPROPRIATE THINGS TO SET IT UP. ! ! 2. THEN WE MUST SEE IF THERE ARE BINDS, ! ETC FOR A LIST OF IDENTIFIERS WHICH ! WE PROCESS NOW.SINCE THE FOLLOWING ! IS LEGAL, WE MUST DO THESE ! INSIDE STEPS AN ARBITRARY NUMBER OF ! TIMES: ! ! X:Z:T[100]:P:R[29,4]:D:C ! ! HERE WE SEE THAT THERE ARE 3 ! DECOMPOSABLE UNITS WHICH SHOULD ! BE TREATED THE SAME, THEY ARE: ! ! X:Z:T[100] ! P:R[29,4] ! D:C ! ! C. KEEP DOING PART [1.B] UNTIL ! THERE ARE NO MORE COMMAS. ! ! D. THE LAST DELIMITER SHOULD BE ';', AND THERE ! IS AN ERROR IF IT IS NOT. Routine GROMLIST(GRLTYPE,GRLFUN,GRLEQL) : Novalue = Begin Macro CHECK(ROUTNAME)=(If ROUTNAME() Then Return) %, OTHERCHECKS= Begin CHECK(STARTCOL); While .DEL Eql TK_COLON Do CHECK(CONTIDLIST); CHECK(DOSIZE); CHECK(DOEQL); CHECK(ENDIDBATCH) End %, NAMEPROC= Begin CHECK(STARTLNKG); CHECK(STARTNAME); Do OTHERCHECKS While If .DEL Eql TK_COLON Then (RUND(QL_NAME);1) Else 0 End %; Local SAVTYPE,SAVFUN,SAVEQL,SAVFLAGS; pos_open = .pos_del; SAVTYPE = .OTYPE; SAVFUN = .OFUN; SAVEQL = .OEQL; SAVFLAGS = .OFLAGS; OTYPE = .GRLTYPE; OFUN = .GRLFUN; OEQL = .GRLEQL; OFLAGS = .GRLTYPE Neq 0; Do Begin RUND(QL_NAME); NAMEPROC End While .DEL Eql TK_COMMA; OTYPE = .SAVTYPE; OFUN = .SAVFUN; OEQL = .SAVEQL; OFLAGS = .SAVFLAGS End; Routine PGLOBAL(FIRST : Boolean,SIZE : Integer,S : Ref ST) = Begin Return DEFGLO(.S,.OFLAGS,.FIRST,.SYM) End; Routine POWN(FIRST : Boolean,SIZE : Integer,S : Ref ST) = Begin DEFOG(NEXTOWN,.S,.OFLAGS,.FIRST,.SYM); S[gt_mode] = ABSOLUTE; Return FALSE End; Routine PSTACKLOCAL(FIRST : Boolean,SIZE : Integer,S : Ref ST) = Begin ALLIGN(NEXTLOCAL,BYTES(S)); NEXTLOCAL = .NEXTLOCAL+.STE[st_var_size]; STE[gt_disp] = -.NEXTLOCAL; S[gt_reg] = SP; S[gt_mode] = INDEXED; S[st_v_nouplevel] = TRUE; INITSYMLSTS(.S); Return FALSE End; Routine PLOCAL(FIRST : Boolean,SIZE : Integer,S : Ref ST) = Begin Local TN : Ref GT; If .SIZE Neq 2 Then Return PSTACKLOCAL(.FIRST,.SIZE,.S); TN = S[gt_reg] = GETTN(); TN[tn_request] = DECREQDB; TN[tn_depth] = .LOOPDEPTH; S[gt_mode] = GENREG; S[st_v_nouplevel] = TRUE; INITSYMLSTS(.S); Return FALSE End; !I. GENERAL: ! ! 1. THIS ROUTINE HANDLES THE SPECIFIC PROCESSING FOR ! THE EXTERNAL DECLARATION. ! !II. SPECIFIC: ! ! 1. * ! ! A. SIMPLY SET THE ADDITIONAL INFORMATION WORD ! TO A UNIQUE NUMBER REPRESENTING THE EXTERNAL ! TYPE FOR LATER PROCESSING BY THE LOADER ! INTERFACE. Global Routine PEXTERNAL(FIRST : Boolean,SIZE : Integer,S : Ref ST)= Begin S[gt_reg] = PC; S[gt_disp] = 0; S[gt_mode] = ABSOLUTE; INITSYMLSTS(.S); Return FALSE End; Routine PLABEL(FIRST : Boolean,SIZE : Integer,S : Ref ST) = Begin Return FALSE End; !I. GENERAL: ! ! 1. THIS ROUTINE PERFORMS THE FUNCTIONS UNIQUE TO ! REGISTER DECLARATIONS. ! !II. SPECIFIC: ! ! 1. * ! ! A. IF THERE WAS AN EQUAL SIGN, THEN THE ! REGISTER IS DECLARED AS AN ABSOLUTE ! TYPE. ! ! B. OTHERWISE, WE ACQUIRE THE REGISTER, INSERT ! IT INTO THE LITERAL TABLE, AND SET THE ! ADDITIONAL INFORMATION FIELD TO THIS ! LITERAL TABLE INDEX. Routine PREGISTER(FIRST : Boolean,SIZE : Integer,S : Ref ST)= Begin Local TN : Ref GT, NUM : Integer; TN = S[gt_reg] = GETTN(); S[gt_mode] = GENREG; S[st_v_nouplevel] = TRUE; If .OFLAGS Then Begin NUM = .SYM; TN[tn_request] = SRREQDB; TN[gt_reg] = .NUM; If .RESERVED<.NUM,1,0> Then S[st_v_nouplevel] = FALSE End Else TN[tn_request] = ARREQDB; TN[tn_depth] = .LOOPDEPTH; INITSYMLSTS(.S); Return FALSE End; Routine PBIND(FIRST : Boolean,SIZE : Integer,S : Ref ST)= Begin S[st_bind_data] = .SYM; S[st_v_nouplevel] = (Case .SYM From 1 To 3 Of Set [ T_LITERAL ]: FALSE; [ T_SYMBOL ]: .SYM[st_v_nouplevel]; [ T_NODE ]: TRUE Tes); Return TRUE End; Routine PGLOBBIND(FIRST : Boolean,SIZE : Integer,S : Ref ST) = Begin S[st_bind_data] = .SYM; S[st_v_gbl_bind] = TRUE; Return TRUE End; Global Routine PROCPARMS(RNAME : Ref ST)= Begin Own PCPS : Vector[2] Initial(AZ('OLDPC','OLDPS')); Macro ISTRAPTYPE= ONEOF(.LNKT,LNK_EMT,LNK_INTERRUPT,LNK_TRAP,LNK_IOT) %; Macro OLDPCPS= (If ISTRAPTYPE Then Begin Local SSYM; SSYM = .SYM; Decr I From 1 To 0 Do Begin SYM = FASTLEXOUT(T_NAME,SEARCH(.PCPS[.I],S_UNDECLARE)); DECLARESYM(FORMAL,S_FORMAL,0); NP = .NP+1; DEFASYM(.FORMAL,2,0,16); FORMAL[st_var_actuals] = .sym_vector; FORMAL[st_v_no_acts] = 1; FORMAL[gt_disp] = .LSF; LSF = .FORMAL; FORMAL[gt_reg] = SP; FORMAL[gt_mode] = INDEXED End; SYM = .SSYM; -2 End Else 0) %; Macro NEXTFORMDESC= If (FNO = .FNO+1) Gtr .LNKG[parm_size] Then FT = PARM_STACK Else Begin FT = .LNKG[parm_type(.FNO)]; FL = .LNKG[parm_loc(.FNO)] End %; Local T : Ref ST, LNKG : Ref ST, LNKT : Ref ST, FORMAL : Ref ST Alias, FT,FL,FNO,LSF,NP; Label aaa; NP = 0; LSF = 0; FNO = 0; LNKG = .RNAME[st_var_linkage]; LNKT = .LNKG[st_lnk_type]; LNKG = .LNKG[st_lnk_desc]; RNAME[st_var_reg_list] = MAKHDR(PARAMREMOVE,PARAMENTER); If .DEL Eql TK_CALL Then Begin While .DEL Neq TK_RPAREN Do aaa: Begin RUND(QL_NAME); If Not DECLARESYM(FORMAL,S_FORMAL,0) Then Leave aaa; NP = .NP+1; DEFASYM(.FORMAL,2,0,16); FORMAL[st_var_actuals] = .sym_vector; FORMAL[st_v_no_acts] = TRUE; NEXTFORMDESC; Case .FT From LO_PARM_TYPE To HI_PARM_TYPE Of Set [PARM_STACK]: Begin FORMAL[gt_disp] = .LSF; LSF = .FORMAL; FORMAL[gt_reg] = SP; FORMAL[gt_mode] = INDEXED End; [PARM_REGISTER]: Begin FORMAL[gt_mode] = GENREG; FORMAL[st_var_reg_index] = .FL; T = FORMAL[gt_reg] = GETTN(); T[tn_depth] = .LOOPDEPTH; T[tn_lon_fu] = 1; T[tn_lon_lu] = 1; T[tn_fon_fu] = 1; T[tn_fon_lu] = 1; ! SPAN MUST START AT 1 ENLST(.RNAME[st_var_reg_list],MAKITEM(.FL^32+.FORMAL)) End; [PARM_LITERAL]: Begin FORMAL[gt_type] = S_BIND; FORMAL[st_bind_data] = LITLEXEME(.FL) End; [PARM_MEMORY]: Begin FORMAL[gt_type] = S_BIND; FORMAL[st_bind_data] = LEXOUT(T_SYMBOL,.FL) End Tes; FORMAL[st_v_nouplevel] = TRUE; If .DEL Neq TK_RPAREN And .DEL Neq TK_COMMA Then Begin ERROR(.pos_open,.pos_del,.LASTEND,DCLDELERR); Return 0 End; INITSYMLSTS(.FORMAL) End End; FNO = OLDPCPS; While .LSF Neqa 0 Do Begin FORMAL = .LSF; LSF = .FORMAL[gt_disp]; FORMAL[gt_disp] = FNO = .FNO+2; If ONEOF(.LNKT,LNK_HYDRA,LNK_IHYDRA) Then FORMAL[gt_disp] = .FORMAL[gt_disp]+8 End; RNAME[st_rout_argc] = .NP; If .DEL Eql TK_RPAREN Then RUNDE(); Return TRUE End; Routine GLOBROUT : Novalue = Begin Local S : Ref ST, LNKGNM : Ref ST; Do Begin RUND(QL_NAME); GETLNKG(LNKGNM); CKFORWD(S,S_GBL_ROUTINE); DEFMAP(.S); S[st_var_linkage] = .LNKGNM; S[gt_reg] = PC; S[gt_mode] = ABSOLUTE; RNAMEFOLLOWS(.S) End While .DEL Eql TK_COMMA End; ! GENERAL DECLARATION ROUTINES ! ---------------------------- ! !SYNTAX: ,..., ! ! ::= ...: ! ::=/ ! ::=:...: ! ::=/[,...,] ! ::=/ = ! !I. GENERAL: ! ! 1. THE FOLLOWING SEVEN(7) ROUTINES, (SLOCAL, ! SOWN,SGLOBAL,SEXTERNAL,SREGISTER,SBIND,SMAP), ARE ALL ! ROUTINES WHICH DECLARE THE LIST OF IDENTIFIERS ! AS THE TYPE WHICH THEIR NAME IMPLIES. ! ! 2. THEY ARE ALL OF THE SAME FORM, IE THEY ALL CALL ! 'GROMLIST' WITH THE FOLLOWING PARAMETERS: ! ! A. #1 - TYPE WHICH SYMBOLS SHOULD BE DECLARED ! AS. NOTE THAT 'MAP' HAS NO TYPE ! ASSOCIATED WITH IT. ! ! B. #2 - A POINTER TO A VARIABLE WHICH CONTAINS ! THE TOTAL NUMBER OF VARIABLES OF THAT ! TYPE DECLARED SO FAR. FOR LOCALS, ONLY ! THE DIFFERENCE BETWEEN THAT NUMBER ON ! ENTRANCE AND EXIT OF A BLOCK IS OF ! INTEREST, BU FOR OWNS AND GLOBALS, ! THE TOTAL NUMBER IS NECESSARY, SINCE ! THATS HOW MUCH SPACE SHOULD BE ALLOCATED. ! ! C. #3 - NAME OF A ROUTINE TO HANDLE THE ! PECULIARITIES DUE TO A SPECIFIC ! TYPE OF DECLARATION. ! ! D. #4 - ROUTINE TO HANDLE AN EQUAL SIGN ('=') ! FOLLOWING A NAME (TO BE BOUND). ! ! E. #5 - ROUTINE TO HANDLE ' = ' AFTER A NAME. Routine SLOCAL : Novalue = Begin GROMLIST(S_LOCAL,PLOCAL,0) End; Routine SSTACKLOCAL : Novalue = Begin GROMLIST(S_LOCAL,PSTACKLOCAL,0) End; Routine SOWN : Novalue = Begin GROMLIST(S_OWN,POWN,OWNEQ) End; Routine SGLOBAL : Novalue = Begin RUND(QL_NAME); If .SYM Eql TK_EMPTY Then Selectone .DEL Of Set [DCLROU]: ! GLOBAL ROUTINE Begin GLOBROUT(); Return End; [DCLBIN]: ! GLOBAL BIND Begin SGLOBBIND(); Return End Tes; PEEKBIT = TRUE; GROMLIST(S_GLOBAL,PGLOBAL,GLOBALEQ) End; Routine SEXTERNAL : Novalue = Begin GROMLIST(S_EXTERNAL,PEXTERNAL,0) End; Routine SDCLLABEL : Novalue = Begin GROMLIST(S_LABEL,PLABEL,0) End; Routine SREGISTER : Novalue = Begin GROMLIST(S_REGISTER,PREGISTER,REGEQ) End; Routine SGLOBBIND : Novalue = Begin GROMLIST(S_BIND,PGLOBBIND,-GLBINDEQ) End; Routine SBIND : Novalue = Begin GROMLIST(S_BIND,PBIND,-BINDEQ) End; Routine SROUTINE : Novalue = Begin Local S : Ref ST, LNKGNM : Ref ST; Do Begin RUND(QL_NAME); GETLNKG(LNKGNM); CKFORWD(S,S_ROUTINE); DEFMAP(.S); S[st_var_linkage] = .LNKGNM; S[gt_reg] = PC; S[gt_mode] = (If .swit_pic Then RELATIVE Else ABSOLUTE); RNAMEFOLLOWS(.S) End While .DEL Eql TK_COMMA End; Routine SMAP : Novalue = Begin GROMLIST(0,0,0) End; Routine SSETSIZE(N) : Novalue = Begin DECLSIZE = .N; RUND(QL_LEXEME); If .SYM Neq TK_EMPTY Then Begin ERROR(.pos_open,.pos_sym,.LASTEND,DECLSYMERR); Return End; If .DEL Neq DCLRTR Then Begin ERROR(.pos_open,.pos_del,.LASTEND,ERRBYTEFOL); Return End; SXCTDECL; DECLSIZE = 2 End; Routine SBYTE : Novalue = Begin SSETSIZE(1) End; Routine SWORD : Novalue = Begin SSETSIZE(2) End; !I. GENERAL: ! ! 1. THIS ROUTINE IS USED TO DECLARE A REGISTER FOR THE ! INDEX OF AN 'INCR' OR 'DECR' LOOP EXPRESSION. ! !II. SPECIFIC: ! ! 1. * ! ! A. OPEN A NEW BLOCK. ! ! B. SET DECLARATION FLAGS. ! ! C. DECLARE THE REGISTER, AND RETURN IF ! THERE ARE ANY ERRORS. ! ! D. DO THINGS UNIQUE TO REGISTER DECLARATION. Global Routine INCRDECRREG= Begin Local REGSTE : Ref ST; BLOCKLEVEL = .BLOCKLEVEL+1; OFLAGS = 0; OFLAGS = TRUE; RUND(QL_NAME); If Not DECLARESYM(REGSTE,S_LOCAL,TRUE) Then Return FALSE; PLOCAL(0,2,.REGSTE); REGSTE[gt_pos] = 0; REGSTE[gt_len] = 16; Return TRUE End; Routine SSWITCHES : Novalue = Begin Local pos_open; pos_open = .pos_del; SWITCHER(SWSWL); If .DEL Neq TK_SEMICOLON Then Begin ERROR(.pos_open,.pos_del,.LASTEND,DCLDELERR); Return End End; ! ! DECLARE MODULE NAME AS A GLOBAL ROUTINE. ! A CALL ON THIS MUST BE PAIRED, OF COURSE, WITH ! A LATER CALL ON BLOCKPURGE. ! Routine DCLMODNAME : Novalue = Begin Local NAME : Ref NT; BLOCKLEVEL = .BLOCKLEVEL+1; NAME = SEARCH(.MODNAME,S_UNDECLARE); STE = STINSERT(.NAME,S_GBL_ROUTINE,0); LNKGLX = .sym_bliss; DEFASYM(.STE,WRDSZ/8,0,16); DEFGLO(.STE,FALSE,0,0) End; Global Routine DOMODULE : Novalue = Begin FLOWINIT(); RUND(QL_NAME); If .SYM Neq TK_EMPTY Then Begin MODNAME = SYM[nt_data]; CSNAME = .MODNAME; CSFLAG = TRUE; SYM = TK_EMPTY End; If .DEL Eql TK_CALL Then Begin SWITCHER(ALLSW); If .DEL Eql TK_RPAREN Then RUND(QL_LEXEME) End; If .DEL Neq TK_EQUAL Or .SYM Neq TK_EMPTY Then WARNEM(.pos_del,WABADMOD) Else RUND(QL_LEXEME); DCLMODNAME(); EXPRESSION(); If .DEL Neq TK_ELUDOM Then WARNEM(0,WAMODDOM); BLOCKPURGE(); GETNCSE() End; Routine GETCONS = Begin If .DEL Eql TK_RPAREN Then SYM = ZERO Else Begin RUND(QL_LEXEME); If .SYM Eql TK_EMPTY Then SYM = ZERO End; Return .SYM Eql T_LITERAL And (.DEL Eql TK_COMMA Or .DEL Eql TK_RPAREN) End; Routine GETSTRING = Begin RUND(QL_STRING_L); If .SYM Eql TK_EMPTY Then SYM = ZERO; Return (.SYM Eql T_STRING_L Or .SYM Eql T_LITERAL) And (.DEL Eql TK_COMMA Or .DEL Eql TK_RPAREN) End; !I. GENERAL ! ! 1. THIS ROUTINE IS USED TO PROCESS A LIST OF SWITCHES ! SEPARATED BY COMMAS. ! ! 2. THE PARAMETER IS THE INDEX INTO THE PLIT SWTBL ! OF THE LAST SWITCH WHICH IS CONSIDERED VALID IN ! THE CURRENT CONTEXT. Routine SWITCHER(HIGH : Integer) = Begin Macro SYCHK(X)=If X Then WARNEM(.pos_open,WASWSYN) %; Local pos_open : Integer, N : Ref Vector[,Byte], X : Integer; pos_open = .pos_del; Do Begin RUND(QL_NAME); N = .SYM[nt_data]; X = (Incr I From 0 To .HIGH Do If ch$eql(.N,SYM[nt_data]+1,.N,.SWTBL[.I]) Then Exitloop .I); Case .X+1 From 0 To 28 Of Set [ 0]: WARNEM(.pos_open,WASWNONX); !WARNING, NOT FOUND [ 1]: swit_expand = TRUE; ! EXPAND MACRO [ 2]: swit_expand = FALSE; ! DON'T EXPAND MACRO [ 3]: swit_list = TRUE; ! LIST [ 4]: swit_list = FALSE; ! NO LIST [ 5]: swit_errors = TRUE; ! ERR MSGS TO TTY [ 6]: swit_errors = FALSE; ! NO ERR MSGS TO TTY [ 7]: swit_optimize= TRUE; ! OPTIMIZE [ 8]: swit_optimize= FALSE; ! NO-OPTIMIZE [ 9]: swit_unames = TRUE; ! GENERATE UNIQUE NAMES [10]: swit_unames = FALSE; ! DO NOT GENERATE UNIQUE NAMES [11]: swit_final = TRUE; ! DO FINAL PEEPHOLE OPTIMIZATION [12]: swit_final = FALSE; ! DO NOT DO FINAL PEEPHOLE OPTIMIZATION [13]: swit_mark = FALSE; ! TURN ON UNCERTAIN OPTIMIZATIONS [14]: swit_mark = TRUE; ! TURN OFF ' ' [15]: swit_zip = TRUE; ! CHOOSE SPEED OVER TIME [16]: swit_zip = FALSE; ! CHOOSE TIME OVER SPEED [17]: swit_debug = TRUE; ! GENERATE SIX12 SYMBOL & NAME TABLES [18]: swit_debug = FALSE; ! DO NOT DO ABOVE [19]: swit_pic = TRUE; ! POSITION INDEPENDENT CODE [20]: swit_pic = FALSE; ! NO POSITION INDEPENDENT CODE [21]: swit_i_d = TRUE; ! NO DATA ALLOWED IN CODE CSECT [22]: swit_i_d = FALSE; ! DATA [23]: SYCHK(SSTART()); ! STARTING ADDRESS DECLARATION [24]: SSTACK(DEFAULTSSTK); ! STACK DECLARATION [25]: SYCHK(SMAIN()); ! MAIN DECLARATION [26]: SYCHK(SRESERVE()); ! RESERVE SPECIFIC REGS. [27]: SYCHK(SIDENT()); ! IDENT [28]: NOTREE = -1 ! SYNTAX CHECK ONLY Tes End Until .DEL Neq TK_COMMA; Return FALSE End; Routine SIDENT = Begin If .DEL Neq TK_EQUAL Then Return TRUE; If GETSTRING() Then Begin IDENTLEX = .SYM; IDENTFLG = TRUE; Return FALSE End; Return TRUE End; Routine SSTACK(X : Integer) = Begin MODMAIN = .MODNAME; SSTKLEN = .X; MAINDECL = TRUE; Return TRUE End; Routine SMAIN = Begin SSTACK(0); If .DEL Eql TK_COMMA Or .DEL Eql TK_RPAREN Then Return FALSE; If .DEL Neq TK_CALL Then Return TRUE; If Not GETCONS() Then Return TRUE; SSTKLEN = .SYM; If .DEL Neq TK_RPAREN Then Return TRUE; RUND(QL_LEXEME); If .SYM Neq TK_EMPTY Then Return TRUE; Return FALSE; End; Routine SSTART = Begin If .DEL Neq TK_EQUAL Then Return TRUE; RUND(QL_NAME); If .SYM Neq T_NAME Or (.DEL Neq TK_COMMA And .DEL Neq TK_RPAREN) Then Return TRUE; MODMAIN = SYM[nt_data]; Return FALSE End; ! RESERVE=(ctce,...) - mark registers as reserved Routine SRESERVE = Begin ! check for '(' If .DEL Neq TK_CALL Then Return TRUE; ! loop for each register Do Begin ! get the register index If Not GETCONS() Then Return TRUE; SYM = .SYM; ! cannot reserve R0, SP, or PC or any other invalid number If .SYM Lss 1 Or .SYM Gtr 5 Then WARNEM(.pos_sym,WACANTRES) Else RESERVED<.SYM,1,0> = TRUE End Until .DEL Neq TK_COMMA; ! skip over the ')' (but who checked for a ')'?) RUND(QL_LEXEME); ! why not RUNDE? If .SYM Neq TK_EMPTY Then Return TRUE; Return FALSE End; ! parse macro/structure parameters Routine PPARAM(TYP : Integer,INITOFF : Integer,RBRACK : Integer) = Begin Local PARAM : Ref ST, OFFST; ! skip over the '['/'(' and get the first name OFFST = .INITOFF; RUND(QL_NAME); ! if an empty parameter list (e.g. '()' then make it look like there ! were no parameters at all. ! ! why is 'MACRO FOO' treated the same as 'MACRO FOO()'? If .SYM Eql TK_EMPTY And .DEL Eql .RBRACK Then Begin RUNDE(); Return 0 End; ! loop for each parameter While TRUE Do Begin If DECLARESYM(PARAM,.TYP,0) Then Begin PARAM[st_which] = .OFFST; OFFST = .OFFST+1 End; If .DEL Neq TK_COMMA Then Exitloop; RUND(QL_NAME); End; ! check for the closing bracket If .DEL Neq .RBRACK Then Begin ERROR(.pos_open,.pos_del,.LASTEND,ERSMSQBCLOSE); Return 0 End; RUNDE(); Return .OFFST - .INITOFF End; ! STRUCTURE declaration Routine SSTRUCTURE : Novalue = Begin Local SAVENME : Ref ST, STREAM : Ref Vector; ! cannot define a structure while in another structure definition ! or inside a macro definition. this is due to the stream mechanisms ! in use. If .MACRCP Or .STRUCP Then STOP(9); ! loop for each structure to declare Do Begin ! get the structure name and declare it as a structure RUND(QL_NAME); SAVENME = .SYM; If Not DECLARESYM(sym_define,S_STRUCTURE,TRUE) Then Return; ! note a redeclaration of 'VECTOR' If .SAVENME Eql .sym_vector[st_name] Then sym_vector = .sym_define; ! structure arguments go in their own scope BLOCKLEVEL = .BLOCKLEVEL+1; ! note the level if this structure definition. symbols encountered ! inside this level are kept as names. symbols outside it are bound. STRUCLEVEL = .BLOCKLEVEL; ! what does it mean to have a structure with no parameters? If .del Eql TK_LBRACKET Then num_actuals = PPARAM(S_STRUCT_ARG,3,TK_RBRACKET) Else num_actuals = 0; sym_define[st_str_argc] = .num_actuals; ! '=' separates parameters from body If .DEL Neq TK_EQUAL Then Begin ERROR(.pos_open,.pos_del,.LASTEND,ERMEQ); Return End; ! skip over the '='. a '[' indicates the start of an allocation ! expression RUND(QL_LEXEME); If .SYM Eql TK_EMPTY And .DEL Eql TK_LBRACKET Then Begin RUND(QL_LEXEME); STREAM = STRUSC(TRUE); If .DEL Neq TK_RBRACKET Then Begin ERROR(.pos_open,.pos_del,.LASTEND,ERSMSQBCLOSE); Return End; DEL = TK_EQUAL; !HIDE THE SPECIAL USE OF [] FROM LEXAN RUND(QL_LEXEME); sym_define[st_str_alloc] = .STREAM End Else sym_define[st_str_alloc] = 0; ! parse the structure body sym_define[st_str_body] = STRUSC(FALSE); STRUCLEVEL = %x'7fffffff'; ! at this point, FUTSYM contains the name of the next structure ! name. make sure it has a block level one lower. If .DEL Eql TK_COMMA Then FSYMPROTECT(); BLOCKPURGE() End While .DEL Eql TK_COMMA End; Routine SMACRO : Novalue = Begin Local SUBTYP : Integer, QUIT : Boolean, SAVCOPY : Integer; ! cannot define a macro within another macro definition or within a structure ! definition If .MACRCP Or .STRUCP Then STOP(9); ! loop for each macro to declare Do Begin ! get the name to declare and declare it as a macro RUND(QL_NAME); If Not DECLARESYM(MACRDEF,S_MACRO,TRUE) Then Return; ! place the macro arguments in their own scope BLOCKLEVEL = .BLOCKLEVEL+1; MACRDEF[st_mac_num_fixed] = 0; MACRDEF[st_mac_num_ited] = 0; SUBTYP = 0; ! check for fixed parameters If .DEL Eql TK_CALL Then Begin MACRDEF[st_mac_num_fixed] = PPARAM(S_MACRO_ARG,1,TK_RPAREN); If .MACRDEF[st_mac_num_fixed] Neq 0 Then SUBTYP = TRUE End; ! check for iterated parameters If .DEL Eql TK_LBRACKET Then Begin MACRDEF[st_mac_num_ited] = PPARAM(S_MACRO_ARG, .MACRDEF[st_mac_num_fixed]+1,TK_RBRACKET); If .MACRDEF[st_mac_num_ited] Eql 0 Then SUBTYP = TRUE Else SUBTYP = TRUE End; BLOCKLEVEL = .BLOCKLEVEL-1; MACRDEF[st_mac_type] = .SUBTYP; If .DEL Neq TK_EQUAL Then Begin ERROR(.pos_open,.pos_del,.LASTEND,ERMEQ); Return End; ! SEE ALSO STRUSC AND STRUCOPY SAVCOPY = .MACRCP; MACRCP = TRUE; SCANTYPE = 'M'; pos_scan = .pos_del; ! loop until an unquoted '$' is reached QUIT = FALSE; Until .QUIT Do Begin ! get a sym/del pair RUND(QL_MACRO); ! SCANFOR was not allowed to bind macro arguments because it would ! have then tried to evaluate them. we therefore do the binding here. If Not .QUOTE_SYM And .SYM Eql T_NAME Then If .ST[.SYM[nt_symb],gt_type] Eql S_MACRO_ARG Then Begin SYM = T_MACRO_ARG; SYM = .ST[.SYM[nt_symb],st_which] End; ! if an unquoted '$', exit or set to exit the loop If Not .QUOTE_DEL And .DEL Eql '$' Then If .SYM Eql TK_EMPTY Then Exitloop Else Begin DEL = 0; QUIT = TRUE End; ! add sym and del to the macro definition STRMAPPEND(WSTBUF,WSTMAX-1) = FORMWINDOW(.SYM,.DEL) End; ! save the body MACRDEF[st_mac_body] = STRMQUIT(WSTBUF); ! we decremented the block level above for error recovery. restore ! it so we may purge the macro parameters BLOCKLEVEL = .BLOCKLEVEL+1; BLOCKPURGE(); SCANTYPE = ' '; MACRCP = .SAVCOPY; ! skip over the '$' If RUNDE() Then Return End While .DEL Eql TK_COMMA End; Macro RUNSC=Until .DEL Eql TK_SEMICOLON Do RUND(QL_LEXEME) %; Routine GETSTRING2 = Begin RUND(QL_STRING_L); If .SYM Eql TK_EMPTY Then SYM = ZERO; Return (.SYM Eql T_STRING_L Or .SYM Eql T_LITERAL) And (.DEL Eql TK_COMMA Or .DEL Eql TK_SEMICOLON) End; Routine SCSECT : Novalue = Begin Local X : Integer, Y : Integer, Z : Ref Vector[,Byte], FLG : Integer, pos_open : Integer; Own FLGPLIT : Vector[5] Initial(CSCFLG,CSDFLG,CSGFLG,CSOFLG,CSPFLG), NAMEPLIT : Vector[5] Initial(CSCNAME,CSDNAME,CSGNAME,CSONAME,CSPNAME); pos_open = .pos_del; Y = 0; If .DEL Eql TK_CSECT Then FLG = 1 ! CSECT Else FLG = 2; ! PSECT ! loop for each psect declaration Do Begin ! get the psect name RUND(QL_NAME); Y = .Y+1; ! if one of the psect names which happen to match a keyword If .SYM Eql TK_EMPTY Then Selectone .DEL Of Set [TK_OWN]: z = AZ('OWN'); [TK_GLOBAL]: z = AZ('GLOBAL'); [TK_PLIT]: z = AZ('PLIT'); [Otherwise]: z = 0 Tes Else Z = SYM[nt_data]; RUND(QL_LEXEME); If .DEL Neq TK_EQUAL Then Begin WARNEM(.pos_open,WBADCSECT); RUNSC; Return End; X = (Incr I From 0 To .KWTBL[-1]-1 Do If ch$eql(.Z[0],.Z+1,.Z[0],.KWTBL[.I]) Then Exitloop .I); If .X Lss 0 Then Begin If .DEL Eql TK_SEMICOLON And .Y Eql 1 Then Begin CSNAME = .Z; CSFLG = .FLG; CSFLAG = TRUE End Else Begin WARNEM(.pos_open,WBADCSECT); RUNSC; Return End End Else Begin If Not GETSTRING2() Then Begin WARNEM(.pos_open,WBADCSECT); RUNSC; Return End; Z = .FLGPLIT[.X]; Z[0] = .FLG; .NAMEPLIT[.X] = .SYM End End Until .DEL Neq TK_COMMA; Return FALSE End; Routine SLNKGDECL : Novalue = Begin Literal NP = 30; Local S : Ref ST, LP : Ref ST, P : Vector[NP], Z : Ref Vector[,Byte], N,LT, K, SAVENME; Macro RERR(EN)= Begin ERROR(.pos_open,.pos_sym,.LASTEND,(EN)); Return End %; Macro RERRD(EN)= Begin ERROR(.pos_open,.pos_sym,PSPAR,(EN)); Exitloop End %; ! loop for each linkage to declare Do Begin ! get the linkage name N = 0; RUND(QL_NAME); SAVENME = .SYM; If Not DECLARESYM(S,S_LINKAGE,TRUE) Then Return; ! look for a '=' followed by the linkage type name If .DEL Neq TK_EQUAL Then RERR(LNKGNOEQUAL); RUND(QL_LEXEME); If .SYM Neq T_SYMBOL Then RERR(LNKGNOTYP); If .SYM[gt_type] Neq S_LINKAGE Then RERR(LNKGNOTYP); LT = .SYM[st_lnk_type]; ! if this is a redeclaration of the BLISS linkage, note it. If .SAVENME Eql .sym_bliss[st_name] Then sym_bliss = LEXOUT(T_SYMBOL,.S); ! if there is a description of the arguments If .DEL Eql TK_CALL Then ! loop for each argument While TRUE Do Begin ! bump the count and check for too many parameters N = .N + 1; If .N Gtr NP Then RERRD(LNKGTOOMANYP); ! get the parameter type. RUND(QL_NAME); Z = SYM[nt_data]; ! if 'REGISTER=ctce' If .SYM Eql TK_EMPTY Then Begin If .DEL Neq TK_REGISTER Then RERRD(LNKGINVPARM); RUND(QL_LEXEME); If .DEL Neq TK_EQUAL Then RERRD(LNKGNOEQUAL); RUND(QL_LEXEME); SYM = BINDBIND(.SYM); K = .SYM; If .SYM Neq T_LITERAL Or .K Gtru 6 Then Begin WARNEM(.pos_sym,LNKGNOTREG); K = 1 End; P[.N-1] = LEXOUT(PARM_REGISTER,.K) End ! if 'STACK' Else If ch$eql(.Z[0],.Z+1,.Z[0],AZ('STACK')) Then P[.N-1] = LEXOUT(PARM_STACK,0) ! if 'MEMORY=ltce' Else If ch$eql(.Z[0],.Z+1,.Z[0],AZ('MEMORY')) Then Begin If .DEL Neq TK_EQUAL Then RERRD(LNKGNOEQUAL); RUND(QL_LEXEME); EXPRESSION(); SYM = BINDBIND(.SYM); Selectone .SYM Of Set [T_LITERAL]: P[.N-1] = LEXOUT(PARM_LITERAL,.SYM); [T_SYMBOL]: If LOADCONST(SYM) Then P[.N-1] = LEXOUT(PARM_MEMORY,.SYM) Else Begin WARNEM(.pos_sym,LNKGINVPARM); P[.N-1] = LEXOUT(PARM_STACK,0); End; [Otherwise]: Begin WARNEM(.pos_sym,LNKGINVPARM); P[.N-1] = LEXOUT(PARM_STACK,0) End Tes End ! not a recognized parameter location type Else RERRD(LNKGINVPARM); If .DEL Eql TK_RPAREN Then Begin RUND(QL_LEXEME); Exitloop End; If .DEL Neq TK_COMMA Then RERRD(LNKGINVSYNTAX) End; ! save the parameters LP = GETSPACE(.N+1); LP[parm_size] = .N; While .N Gtr 0 Do Begin LP[parm_data(.N)] = .P[.N-1]; N = .N-1 End; S[st_lnk_type] = .LT; S[st_lnk_desc] = .LP End Until .DEL Neq TK_COMMA End; ! ! PLIT SYNTAX PROCESSING ROUTINES. THE SYNTAX FOR PLITS IS AS ! FOLLOWS: ! ! ::= PLIT ! ::= ! ! ! ! ! ::= () ! ::= ! ! , ! ::= ! ! ! ! : ! ::= ! ! [NOTE: ::= ! ...] ! Bind PLNEXT=NEXTGLOBAL; Global Routine SPLIT : Novalue = Begin Macro MAKENEWNAME= PLHEAD[4] = .PLHEAD[4] + 1; If .PLHEAD[4] Gtr 'Z' Then Begin PLHEAD[4] = 'A'; PLHEAD[3] = .PLHEAD[3] + 1; If .PLHEAD[3] Gtr 'Z' Then Begin PLHEAD[3] = 'A'; PLHEAD[2] = .PLHEAD[2] + 1 End End %; Local N : Integer, S : Ref ST, PLITP : Ref CELL, ISCOUNTED : Boolean; ! remember whether this is PLIT or UPLIT ISCOUNTED = (.DEL Eql TK_PLIT); ! generate a name for this plit MAKENEWNAME; ! make the plit a global (why global and not own?) S = .NT[SEARCH(PLHEAD,S_GLOBAL),nt_symb]; ! now parse the plit value N = SPLITB(PLITP); ! fill in the defaults for this plit symbol DEFASYM(.S,2*.N,0,16); DEFMAP(.S); ! note that this is a plit and whether it is counted S[st_v_plit] = TRUE; S[st_v_counted] = .ISCOUNTED; ! assign the value to the symbol and give it an address DEFGLO(.S,TRUE,TRUE,.PLITP); SYM = LEXOUT(T_SYMBOL,.S) End; ! parse a plit expression Global Routine SPLITB(GLOSTE) = Begin Local TEMPHEAD : Ref CELL, NEXTCELL : Ref CELL, FIRSTCELL : Ref CELL, OFFST : Integer, SLBRAC : Integer; ! save our context and note that we are in a plit to HRUND SLBRAC = .PLLBRAC; PLLBRAC = .pos_del; flg_plit = TRUE; ! allocate the head of this plit and parse the plit expression TEMPHEAD = GETCELL(PL_LEXEME,SZ_PLIT); OFFST = PLITARG(.TEMPHEAD); flg_plit = FALSE; ! note the plit length in the head and return the head. TEMPHEAD[plit_length] = .OFFST; .GLOSTE = .TEMPHEAD; PLLBRAC = .SLBRAC; Return .OFFST End; Routine PLITARG(HEAD : Ref CELL) = Begin Local LENTH : Integer, SLBRAC : Integer, SAVEL : Integer; ! skip over the word PLIT, telling RUND that strings are acceptable RUND(QL_STRING_L); ! if not a sub-list then it is just a simple expression If .SYM Neq TK_EMPTY Or (.DEL Neq TK_CALL And .DEL Neq TK_LPAREN) Then Return LSORLE(.HEAD); ! setup for parsing a tuple NEWLASTEND(PSPARCOM); SLBRAC = .PLLBRAC; PLLBRAC = .pos_del; LENTH = 0; ! loop for all tuple elements Do Begin RUND(QL_STRING_L); LENTH = .LENTH + TUPLEITEM(.HEAD) End While .DEL Eql TK_COMMA; RESLASTEND; ! check for closing ')' If .DEL Neq TK_RPAREN Then Begin ERROR(.PLLBRAC,.pos_del,.LASTEND,ERSYPLMRP); Return 0 End; ! skip the ')' and disallow any symbol after it. RUNDE(); PLLBRAC = .SLBRAC; Return .LENTH End; ! parse a plit item within '()' Routine TUPLEITEM(HEAD : Ref CELL) = Begin Local LEN : Integer, NEWHEAD : Ref CELL; ! get the item value EXPRESSION(); ! if it was a repeat count then get the repeat value and then ! parse the repeated value If .DEL Eql TK_COLON Then Begin SYM = BINDBIND(.SYM); If Not LITRESULT Then Begin ERROR(.PLLBRAC,.pos_sym,0,ERSMPLNLI); SYM = LITLEXEME(1) End; NEWHEAD = GETCELL(PL_DUPLICATOR,SZ_PLIT); NEWHEAD[plit_replicator] = LEN = .SYM; PUSHBOT(.HEAD,.NEWHEAD); Return .LEN * PLITARG(.NEWHEAD) End Else Return LSORLE(.HEAD) End; Routine LSORLE(HEAD : Ref CELL) = Begin ! strings have already been placed in plit form by the scanner If .SYM Eql T_STRING_L Then Begin LEXTOP(.HEAD,.SYM); Return .SYM[plit_length] End; Case WHICHBIND() From 0 To 2 Of Set [0]: Begin WARNEM(.pos_sym,ERSMPLNLO); SYM = ZERO End; [1]: ; [2]: If .SYM Neq T_SYMBOL Or Not LOADCONST(SYM) Then Begin WARNEM(.pos_sym,ERSMPLNLO); SYM = ZERO End Tes; Return LEXTOP(.HEAD,.SYM) End; Routine LEXTOP(HEAD : Ref CELL,LEX : Ref GT) = Begin Local PCELL : Ref ST; PCELL = GETCELL(PL_LEXEME,SZ_PLIT); PCELL[plit_lexeme] = .SYM; PUSHBOT(.HEAD,.PCELL); Return TRUE End; ! THESE ROUTINES HANDLE THE 'REQUIRE' DECLARATION ! VERY MACHINE DEPENDENT. Routine SREQUIRE : Novalue = Begin SKAN1() !FORCE EOL AND GET NEW LINE FROM REQUIRED FILE End; End Eludom