Trailing-Edge
-
PDP-10 Archives
-
BB-D868D-BM
-
language-sources/cn1n.bli
There are 18 other files named cn1n.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!
!COPYRIGHT (C) 1972,1973,1974,1977,1978 DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS. 01754
!FILENAME: H1CNTR.BLI
!%4.11% 10 SEPTEMBER 1974 MGM/FLD/KR/GJB
%4.01,4.02,4.05,4.09,4.11% GLOBAL BIND H1CNV=18; !MODULE VERSION NUMBER
! REVISION HISTORY
! 9-21-77 ROUTINE GSE0 IS MODIFIED TO REMOVE CAI MACHINE
! FROM MACRO LISTING. IT IS A NOP.
!
! 7-15_77 ROUTINE GSE5 IS MODIFIED TO HAVE NO OPTIMIZATION
! IN SELECT EXPRESSION WHEN TESN IS PROCESSED.
!
! GENERAL DOCUMENTATION FOR CONTROL.BLI
!
! THIS MODULE IS CONCERNED WITH MANIPULATING THE LINKED-LISTS
! WHICH CONTAIN THE CODE AND WITH GENERATING THE CODE FOR CONTROL
! EXPRESSIONS. THE READER IS ADVISED TO READ THE MODULE LOLSTPKG
! BEFORE OR IN PARALLEL WITH THIS ONE. THE FORMATS OF THE LIST
! HEADERS AND ELEMENTS ARE EXPLAINED THERE.
!
! EACH CONTROL ENVIRONMENT GENERATES A SKELETON FROM WHICH
! THE CODE FOR THAT CONTROL EXPRESSION IS SUSPENDED. THE GLOBAL VARIABLE
! CODEPTR IS ALWAYS LEFT POINTING AT THE HEADER FROM WHICH SUBSEQUENT
! CODE IS TO BE GENERATED. IT IS THE RESPONSIBILITY OF THE ROUTINES IN
! THIS MODULE TO POSITION CODEPTR AT THE APPROPRIATE HEADER.
!
! IT IS PROBABLY EASIEST TO INDOCTRINATE THE READER INTO THE
! TYPICAL ACTIVITY OF THESE ROUTINES BY AN EXAMPLE:
!
! ... BEGIN LOCAL A,B; A_F(); ... ; .B END ...
!
! (WHILE READING THIS EXAMPLE YOU WILL NEED TO REFER TO THE FIRST THREE
! ROUTINES OF THIS MODULE.)
!
! WHEN SA(SYNTAX ANALYZER) ENCOUNTERS "BEGIN" FOLLOWED BY A
! DECLARATION IT CALLS GCE0 WITH A PARAMETER OF 1. GCE0 BEGINS BY CREATING
! A SKELETON CONSISTING OF A HEADER AND 4 SUBHEADERS:
!
! \ /
! \ /
! \----/
! !BEC !
! !0 !
! /----\
! / \
! /-------------/ \-------------\
! / \
! /----\ /----\ /----\ /----\
! !BEC !\----/!BEC !\----/!BEC !\----/!BEC !
! !1 ! !2 ! !3 ! !4 !
! ---- ---- ---- ----
!
!
!
! THIS HAS THE SIDE-EFFECT OF LEAVING CODEPTR POINTING TO THE
! HEADER. (NOTE: THROUGHOUT THE MODULE THE POSITION OF CODEPTR IS INDICATED
! BY COMMENTS OF THE FORM: ! --> X WHERE X CORRESPONDS TO A POSITION
! ON THE RELEVANT SKELETON). CODEPTR IS THEN MOVED TO POINT TO SUBHEADER #1
! AND FROM THERE A CODE-CLASS HEADER IS SUSPENDED. A NOOP IS GENERATED
! (GLICH TO AVOID BACKWARD JUMPS PASSING BEYOND A BLOCK). THEN CODEPTR
! IS MOVED TO SUBHEADER #2 (BODY OF THE BLOCK). AT THIS POINT ANY REGISTERS
! WHICH ARE IN USE ARE SAVED. THEN A HEADER OF TYPE CURRENTC IS
! GENERATED. THIS IS USED TO DISTINGUISH THE CODE FOR THE PRESENT EXPRESSION
! IN THE COMPOUND EXPRESSION FROM THE PRECEDING. FINALLY A CODEC HEADER
! IS CREATED FROM WHICH THE CODE OF THE FIRST EXPRESSION WILL BE SUSPENDED.
!
! NOW THE DECLARATION PROCESSOR PROCESSES THE DECLARATIONS OF THE
! BLOCK AND WHEN THE ";" FOLLOWING A_F() IS ENCOUNTERED, GCE1 IS CALLED
! WITH THE LEXEME FOR THE VALUE OF THE EXPRESSION. NOTE THAT CODE FOR
! THE ROUTINE CALL AND THE STORE HAS BEEN HUNG OFF THE CODEC HEADER
! GENERATED IN GCE0. GCE1 FIRST CLEARS THE TRCT LIST OF THE VALUE REGISTER
! IF IT IS INVOLVED IN THE VALUE LEXEME SINCE SIDE-EFFECTS POTENTIALLY
! OCCURED. NEXT THE USE OF ANY REGISTER INVOLVED IN THE VALUE LEXEME
! IS DECREASED (DULEX) SINCE THE FOLLOWING SEMICOLON MEANS THE VALUE WON'T
! BE USED. THE CODEPTR IS MOVED TO THE CURRENTC HEADER. THE LIST
! (POTENTIALLY) OF HEADERS SUSPENDED FROM THE CTC IS SCANNED FOR THOSE
! OF TYPE CONVEY WHICH ARE DISCARDED. A CONVEY HEADER IS ONE WHICH CONTAINS
! THE CODE NECESSARY TO LOAD VREG WITH THE RESULT OF A CONTROL EXPRESSION. IF
! THE VALUE OF THE CONTROL EXPRESSION IS NOT NEEDED, THEN THIS CODE IS
! DISCARDED BY LOSECONV. FOR EXAMPLE:
!
! ...; IF .A THEN C_.B; ...
!
! THE VALUE OF THE IF-EXPRESSION IS NOT USED. THERE MAY ALSO BE HEADERS OF TYPE
! RELC (RELATIONAL-EXPRESSION-CLASS: SEE GREL AND GBREL IN H2ARITH) HANGING
! FROM CTC. IF SO THESE ARE PROMOTED TO TYPE CODEC (SEE PROMOTE IN LOLSTPKG).
! THIS LEAVES CTC EMPTY AND WE CONCLUDE GCE1 BY CREATING A NEW CODEC HEADER
! BENEATH IT.
!
! WHEN SA ENCOUNTERS THE "END", IT CALLS GCE2 WITH THE VALUE
! LEXEME X AND -(# OF LOCALS + 1). FIRST GCE2 CONVEYS THE VALUE LEXEME.
! THAT IS IT GENERATES (IF NECESSARY) CODE TO LOAD VREG WITH X SUSPENDING
! THE CODE FROM A CONVEYC HEADER SO THAT IF THE VALUE IS NOT NEEDED (I.E.
! SEMI-COLON AFTER THE END) THIS CODE CAN BE DISCARDED. GCE2 NOW MIMICS
! GCE1 (PROMOTE-SYPHON) BUT THEN MOVES TO SUBHEADER #2 AND ERASES CTC.
! THEN IT SCANS SUBHEADER #2 FOR ANY XBLOCKC HEADERS AND PROMOTES THEM
! TO CONVEYS. THEN CODEPTR MOVES TO SUBHEADER #3 AND CLASSIFIES IT AS A
! LABEL. NOTE THAT ANY JUMP GENERATED INSIDE THE BODY TO EXIT THIS BLOCK
! WAS MADE TO THIS CELL. ALSO ANY EXIT OF THIS BLOCK TO SOME HIGHER
! CONTROL ENVIRONMENT GENERATED AN XCT OF THIS CELL WHICH SUBSEQUENTLY
! WILL CONTAIN (POTENTIALLY) THE SUBTRACT FROM THE STACK POINTER FOR
! LOCALS OF THE BLOCK. CLASSLAB HAS THE SIDE-EFFECT OF MOVING CODEPTR
! TO SUBHEADER #4. A CODEC CELL IS PUSHED AND THE SUBTRACT IS GENERATED.
! CODEPTR IS SET TO THE CODEC CELL SUPENDED FROM SUBHEADER #1 WHERE THE
! ADD IS GENERATED. THEN CODEPTR IS MOVED TO THE MAIN HEADER, BEC #0.
! THE SKELETON IS REMOVED (NOTE: HEADERS BEC #0, #1, #2, #4 DISAPPEAR BUT
! BEC #3 WHICH IS NOW LABELC REMAINS). THEN GCE2 RETURNS A LEXEME
! REPRESENTING VREG (FROM CONVEY) TO SA WHERE IT BECOMES THE VALUE OF SYM.
!
! HOPEFULLY THIS DISCUSSION BY EXAMPLE WILL GIVE THE READER
! AT LEAST A VAGUE FEELING FOR WHAT TRANSPIRES IN ALL THE CONTROL CLASSES.
! YOU WILL NOTE THAT IN MANY OF THE CLASSES THE MAIN HEADER (#0) IS A
! MULTI-WORD (>2) CELL WHICH CONTAINS INFORMATION NEEDED BY SEVERAL
! OF THE CONTROL ROUTINES OF THE CLASS BUT LOCAL TO THIS PARTICULAR
! INSTANCE OF THE CONTROL EXPRESSION.
!
!
! GLOBALS USED BY THIS MODULE:
!
! CODEPTR POINTS TO HEADER WHERE CODE IS BEING GENERATED
! SFORLABEL BOOLEAN SET WHEN SEARCH BACKWARDS FOR A LABELC
! CELL TO INSURE THAT A LABELC CELL IS FOUND
! NOSAVREG # OF REGISTERS SAVED IN GPROLOG (USED BY GEPILOG)
! PROGRAM INDEX OF CELL WHICH HOLDS CODE OF OUTER BLOCK
FORWARD CONVEY,GCE0,GCE1,GCE2,GCOST0,GCOST1,GCOST2,GCOST3,GCOST4;
FORWARD GCUJUMP,GDWU0,GDWU1,GDWU2,GESCAPE,GEXIT,GID0,GID1,GID2,GID3;
FORWARD GITE0,GITE1,GITE2,GITE3,GRETURN,GUJUMP,GWUD0,GWUD1,GWUD2,LABLE;
FORWARD PUSHMSET,PUSHNSET,PUSHSET;
FORWARD SGC12,SGC34,SGSE12,SGSE3,SINGINSTP;
%
PARENTHESES
( E1 ; ... ; EN )
^ ^ ^ ^
^ ^ ^ ^
GCE0(0) ------------^ ^ ^ ^
^ ^ ^
GCE1(E1) ----------------^-----^ ^
^
GCE2(EN,0) -------------------------^
BEGIN E1 ; ... ; EN END
^ ^ ^ ^
^ ^ ^ ^
GCE0(1) ------------^ ^ ^ ^
^ ^ ^
GCE1(E1) ----------------^-----^ ^
^
GCE2(EN,--) -------------------------^
SKELETON
0 BEC 0 CMPEXC
0.2 BOOLEAN: CMPEXC'S EXIT LABEL REF'D
1 LOCAL ADD 1 BODY
2 BODY 2 LABEL
3 LABEL
4 LOCAL SUB
%
GLOBAL ROUTINE GCE0(N)=
% LEFT PARENTHESIS/BEGIN MET. %
BEGIN
IF .N THEN
BEGIN LOCAL A;
TEMPLATE(2,BEC,4); ! --> 0
ACPDT(); ! --> 1
PUSHCODE(); ! --> \1
CODE(JUMP,0,0,0);
ACPR2(); ! --> 2
PUSHCODE(); ! --> \2
INCR I FROM 16 TO 31 DO
IF .RT[.I]<USEF> NEQ 0 AND NOT .RT[.I]<RSF> THEN
BEGIN
DUMPREG(A_.RT[.I]<ARTEF>);
RELREG(.A,1)
END;
END
ELSE
BEGIN
TEMPLATE(2,CMPEXC,2); ! --> 0
ACPDT(); ! --> 1
PUSHCODE() ! --> \1
END;
FOLLCPH(0,CURRENTC,0); ! --> CTC
CT[.CODEPTR,1]<HDRCLASSF>_#40;
PUSHCODE() ! --> \CTC
END;
GLOBAL ROUTINE GCE1(X)=
% SEMICOLON MET WITHIN PARENTHESES. %
BEGIN
IF .RT[.X<RTEF>]<ARTEF> EQL .VREG THEN CLEARONE(RT[.X<RTEF>]);
DULEX(.X);
ACPR1(); ! --> CTC
LOSECONV();
PROMOTE(1^RELC);
SYPHON(.CODEPTR);
PUSHCODE() ! --> \CTC
END;
GLOBAL ROUTINE GCE2(X,N)=
! RIGHT PARENTHESIS OR END MET
! N=0 COMPOUND EXPRESSION
! N=-1 LOCAL-LESS BLOCK
! N<-1 BLOCK WITH -(N+1) LOCALS
!
BEGIN LOCAL B; ! BOOLEAN INDICATING THE LABEL (CMPEXC #2) HAS
! BEEN REFERENCED. IF THE LABEL HAS NOT BEEN
! REF'D, WE DISCARD IT AT THE END OF GCE2 TO
! FACILITATE OPTIMIZATIONS WHICH SEARCH BACKWARD
! AND WOULD OTHERWISE STOP AT A LABEL. ALSO
! DETERMINES WHETHER THE VALUE OF CMPEXC MUST
! BY CONVEYED IN VREG.
IF .N LSS 0 OR (B_IF .N EQL 0 THEN .CT[LOCATE(CMPEXC,0),2]) THEN
X_CONVEY(.X);
IF .N LSS 0 THEN IF .CT[LOCATE(BEC,0),2] THEN SESTOG_.SESTOG OR 8;
ACPR1(); ! --> CTC
PROMOTE(1^RELC);
SYPHON(.CODEPTR);
ACPR1(); ! --> 2
ERASEBOT(.CODEPTR);
PROMOTE(IF .N EQL 0 THEN 1^XCMPEXC ELSE 1^XBLOCKC);
IF .N LSS -1 THEN
BEGIN LOCAL C,L;
ACPR1(); ! --> 3
CLASSLAB(); ! --> 4
C_.CODEPTR;
PUSHCODE(); ! --> \4
CODE(SUB,.SREG,L_LITA(LITLEXEME(((-.N)-1)*#1000001)),0);
CODEPTR_.CT[LOCATE(BEC,1),1]<NEXTF>; ! --> \1
EMPTY(.CODEPTR);
CODE(ADD,.SREG,.L,0);
CODEPTR_.C; ! --> 4
ACPR1(); ! --> 0
END ELSE
IF .N EQL -1 THEN
BEGIN
EMPTY(.CT[LOCATE(BEC,1),1]<NEXTF>);
ACPR1(); ! --> 3
CLASSLAB(); ! --> 4
PUSHCODE(); ! --> \4
CODE(#320,0,0,0);
ACPR2(); ! --> 0
END
ELSE
BEGIN
ACPR1(); ! --> 2
IF .B THEN CLASSLAB() ELSE ACPR1(); ! --> 0
IF NOT .B THEN ERASEBOT(.CODEPTR) ELSE SESTOG_.SESTOG OR 8
END;
UNTEMPLATE();
IF .CT[.CODEPTR,0]<CLASSF> NEQ CODEC THEN PUSHCODE();
.X
END;
%
DO E1 WHILE E2
^ ^ ^
^ ^ ^
GDWU0() -------------^ ^ ^
^ ^
GDWU1(E1) --------------^ ^
^
GDWU2(E2,1) ---------------------^
DO E1 UNTIL E2
^ ^ ^
^ ^ ^
GDWU0() -------------^ ^ ^
^ ^
GDWU1(E1) --------------^ ^
^
GDWU2(E2,0) ---------------------^
SKELETON
0 DWU
0.3 INDEX AND SUBCLASS OF REAL LABEL
1 LABEL
2 DO
3 WHILE/UNTIL
4 LABEL
%
GLOBAL ROUTINE GDWU0=
% DO HAS BEEN MET COMMENCING A DO-WHILE/UNTIL. %
! THE ROUTINE SWALABEL WHICH IS CALLED HERE AND IN GWUD0 SEARCHES
! BACK FROM THE DWU HEADER TO SEE IF THIS CELL IS PRECEDED BY A LABEL
! CELL WITH NO INTERVENING CODE. IF SO, THE LABEL (DWUC #1) IS
! DISCARDED. THE BACKWARD JUMP AT THE END OF DWUC #3 IS THEN BACK
! TO THIS LABEL. THIS INSURES TO THE LATER OPTIMIZING PASS IN FLATFUNC
! THAT ALL BACKWARD REFERENCES TO A LIST OF CONTIGUOUS LABELS ARE
! ALWAYS TO THE LAST SUCH LABEL. GWUD2 RESOTRES THE SUBCLASS NUMBER
! IF IT WAS CHANGED.
BEGIN
FREEVREG();
TEMPLATE(2,DWUC,4); ! --> 0
SWALABEL(); ! --> 2
PUSHCODE(); ! --> \2
END;
GLOBAL ROUTINE GDWU1(X)=
% DO CLAUSE COMPLETED WITHIN A DO-WHILE/UNTIL. %
BEGIN
IF .RT[.X<RTEF>]<ARTEF> EQL .VREG THEN CLEARONE(RT[.X<RTEF>]);
DULEX(.X);
ACPR1(); ! --> 2
LOSECONV();
PROMOTE(1^RELC OR 1^XLOOPC);
ACPR1(); ! --> 3
PUSHCODE(); ! --> \3
END;
GLOBAL ROUTINE GDWU2(X,N)=
% WHILE(N=1)/UNTIL(N=0) CLAUSE OF DO-WHILE/UNTIL COMPLETED. %
BEGIN LOCAL C;
SFORLABEL_1;
GCUJUMP(.X,LOCATE(DWUC,1),.N,1);
SFORLABEL_0;
ACPR1(); ! --> 3
PROMOTE(1^CNVEYC OR 1^RELC);
ACPDB(); ! --> \3
X_CONVEY(LITLEXEME(-1));
ACPR2(); ! --> 4
CLASSLAB(); ! --> 0
IF (C_.CT[.CODEPTR,3]<LEFTF>) GTR 1 THEN
(.CT[.CODEPTR,3]+1)<CLASSF>_.C;
UNTEMPLATE();
.X
END;
%
WHILE/UNTIL-DO
WHILE E1 DO E2
^ ^ ^
^ ^ ^
GWUD0() ----------------^ ^ ^
^ ^
GWUD1(E1,0) ---------------^ ^
^
GWUD2(E2) -----------------------^
UNTIL E1 DO E2
^ ^ ^
^ ^ ^
GWUD0() ----------------^ ^ ^
^ ^
GWUD1(E1,1) ---------------^ ^
^
GWUD2(E2) -----------------------^
SKELETON
0 WUD
0.2 VALUE RETURNED FROM GCUJUMP
1 LABEL
2 WHILE
3 DO
4 LABEL
5 -1
6 LABEL
%
GLOBAL ROUTINE GWUD0=
% WHILE/UNTIL HAS BEEN MET COMMENCING A WHILE/UNTIL-DO. %
BEGIN
FREEVREG();
TEMPLATE(2,WUDC,6); ! --> 0
SWALABEL(); ! --> 2
PUSHCODE(); ! --> \2
END;
GLOBAL ROUTINE GWUD1(X,N)=
% WHILE(N=0)/UNTIL(N=1) CLAUSE COMPLETED WITHIN A WHILE/UNTIL-DO. %
! THE ROUTINE DROP (SEE LOLSTPKG) IS CALLED HERE TO DISCARD:
! (1) THE DO PORTION IF WE HAVE A WHILE 0 OR UNTIL 1
! OR
! (2) THE CONVEY OF -1 IN THE CASES WHILE 1 OR UNTIL 0.
! NOTE THAT THIS DECISION IS DETERMINED BY THE VALUE RETURNED FROM
! GCUJUMP (LATER IN THIS MODULE
BEGIN
CT[LOCATE(WUDC,0),2]_GCUJUMP(.X,LOCATE(WUDC,4),.N,0);
ACPR1(); ! --> 2
PROMOTE(1^CNVEYC OR 1^RELC);
ACPR1(); ! --> 3
PUSHCODE(); ! --> \3
END;
GLOBAL ROUTINE GWUD2(X)=
% DO CLAUSE COMPLETED WITHIN A WHILE/UNTIL-DO. %
BEGIN LOCAL C;
SFORLABEL_1;
GUJUMP(LOCATE(WUDC,1));
SFORLABEL_0;
IF .RT[.X<RTEF>]<ARTEF> EQL .VREG THEN CLEARONE(RT[.X<RTEF>]);
DULEX(.X);
ACPR1(); ! --> 3
LOSECONV();
PROMOTE(1^RELC OR 1^XLOOPC);
ACPR1(); ! --> 4
CLASSLAB(); ! --> 5
PUSHCODE(); ! --> \5
X_CONVEY(LITLEXEME(-1));
ACPR2(); ! --> 6
CLASSLAB(); ! --> 0
DROP(CASE .CT[.CODEPTR,2] OF
SET 1^4 OR 1^5; 1^3 OR 1^4 OR 1^6; 0 TES);
IF (C_.CT[.CODEPTR,3]<LEFTF>) GTR 1 THEN
(.CT[.CODEPTR,3]+1)<CLASSF>_.C;
UNTEMPLATE();
.X
END;
%
INCR/DECR-FROM-TO-DO
INCR N FROM E1 TO E2 BY E3 DO E4
^ ^ ^ ^ ^
^ ^ ^ ^ ^
GID0(N) --------------^ ^ ^ ^ ^
^ ^ ^ ^
GID1(E1) ---------------------^ ^ ^ ^
^ ^ ^
GID2(E2) ---------------------------^ ^ ^
^ ^
GID3(E3,0) -------------------------------^ ^
^
GID4(E4,0) -------------------------------------^
DECR N FROM E1 TO E2 BY E3 DO E4
^ ^ ^ ^ ^
^ ^ ^ ^ ^
GID0(N) --------------^ ^ ^ ^ ^
^ ^ ^ ^
GID1(E1) ---------------------^ ^ ^ ^
^ ^ ^
GID2(E2) ---------------------------^ ^ ^
^ ^
GID3(E3,1) -------------------------------^ ^
^
GID4(E4,1) -------------------------------------^
SKELETON
0 IDFTD
0.2 INCR/DECR REGISTER LEXEME
0.3 TO-EXPRESSION LEXEME
0.4 BY-EXPRESSION LEXEME
0.5 BOOLEAN: LITERAL FROM-EXPRESSION
0.6 BOOLEAN: VALUE OF LITERAL FROM-EXPRESSION
0.7 BOOLEAN: BODY CAN BE DISCARDED
1 INITIAL
2 LABEL
3 DO
4 LABEL
5 SETO
6 LABEL
%
MACRO IDREGLEXEME=CT[.H,2]$,
LITERALFROM=CT[.H,5]$,
FROMVALUE=CT[.H,6]$,
TOLEXEME=CT[.H,3]$,
BYLEXEME=CT[.H,4]$,
DROPBODY=CT[.H,7]$;
GLOBAL ROUTINE GID0(X)=
% INDEX OF INCR/DECR-FROM-TO-DO MET. %
BEGIN
FREEVREG();
TEMPLATE(4,IDFTDC,6); ! --> 0
CT[.CODEPTR,2]_.X;
ACPDT(); ! --> 1
PUSHCODE(); ! --> \1
END;
GLOBAL ROUTINE GID1(X)=
% FROM CLAUSE OF INCR/DECR-FROM-TO-DO COMPLETED. %
BEGIN REGISTER H;
H_LOCATE(IDFTDC,0);
DULEX(GSTO(.IDREGLEXEME,.X));
IF (LITERALFROM_LITP(.X)) THEN FROMVALUE_LITV(.X);
ACPR1(); ! --> 1
PROMOTE(1^CNVEYC OR 1^RELC);
ACPDB(); ! --> \1
END;
GLOBAL ROUTINE GID2(X)=
!THE TO-CLAUSE HAS BEEN COMPLETED IN AN INCR-DECR LOOP
BEGIN REGISTER H;
H_LOCATE(IDFTDC,0);
IF LITP(.X) THEN TOLEXEME_.X
ELSE DULEX(GSTO(TOLEXEME_GENLOCAL(),.X));
ACPR1(); ! --> 1
PROMOTE(1^CNVEYC OR 1^RELC);
ACPDB() ! --> \1
END;
GLOBAL ROUTINE GID3(X,N)=
!BY CLAUSE IN AN INCR(N=0)/DECR(N=1) LOOP COMPLETED
BEGIN REGISTER IDREG,TOVALUE,BYVALUE,H; LOCAL CPTRSAV,OPCODE;
H_LOCATE(IDFTDC,0);
IDREG_LITV(.IDREGLEXEME) AND #17;
IF LITP(.X) THEN BYLEXEME_.X
ELSE DULEX(GSTO(BYLEXEME_GENLOCAL(),.X));
ACPR1(); ! --> 1
PROMOTE(1^CNVEYC OR 1^RELC);
ACPR1(); ! --> 2
CLASSLAB(); ! --> 3
PUSHCODE(); ! --> \3
IF LITP(.TOLEXEME) THEN
BEGIN
TOVALUE_LITV(.TOLEXEME);
IF .LITERALFROM THEN
DROPBODY_
CASE .N OF SET .FROMVALUE GTR .TOVALUE; .FROMVALUE LSS .TOVALUE TES;
OPCODE_
IF LITP(.X) THEN
BEGIN
BYVALUE_LITV(.X);
IF ABS(.BYVALUE) NEQ 1 THEN EXITCOMPOUND;
IF ABS(.TOVALUE) GTR 1 THEN EXITCOMPOUND;
IF .TOVALUE EQL 0 THEN IF ABS(.BYVALUE) EQL 1 THEN
EXITCOMPOUND
CASE .N OF SET JUMPG; JUMPL TES;
IF .TOVALUE EQL 1 THEN
EXITCOMPOUND
IF (.BYVALUE EQL -1) EQL (.N EQL 0) THEN JUMPLE ELSE 0;
IF (.BYVALUE EQL 1) EQL (.N EQL 0) THEN JUMPGE
END
ELSE 0;
IF .OPCODE NEQ 0 THEN
BEGIN
IF NOT .LITERALFROM THEN
BEGIN
CPTRSAV_.CODEPTR;
CODEPTR_.CT[.H,1]<NEXTF>;
PUSHCODE();
CODE(.OPCODE,.IDREG,LABLE(LOCATE(IDFTDC,4)),0);
CODEPTR_.CPTRSAV
END
END ELSE
IF SMPOSLITVP(.TOVALUE) THEN
BEGIN
CODE(CAILE+2*.N,.IDREG,.TOVALUE,0);
GUJUMP(LOCATE(IDFTDC,4))
END
ELSE
BEGIN
CODE(CAMLE+2*.N,.IDREG,LITA(.TOLEXEME),0);
GUJUMP(LOCATE(IDFTDC,4))
END
END
ELSE
BEGIN
CODE(CAMLE+2*.N,.IDREG,GMA(GAT(.TOLEXEME)),0);
GUJUMP(LOCATE(IDFTDC,4))
END
END;
GLOBAL ROUTINE GID4(X,N)=
!DO CLAUSE COMPLETED IN AN INCR(N=0)/DECR(N=1) LOOP
BEGIN
LOCAL IDREG, !ADDRESS OF INCR REGISTER
BYVALUE, !VALUE OF LITERAL BY-EXPRESSION
OPCODE; !FUNCTION FOR BACKWARD JUMP AND INCR-DECR
REGISTER R,H;
MACRO ADDONECASE=R<0,1>$, !BY-EXPRESSION HAS LITERAL VALUE OF 1
LITERALBY=R<1,1>$, !LITERAL BY-EXPRESSION
AOJSOJCASE=R<2,1>$; !CAN GENERATE AOJ-SOJ TYPE JUMP
IF .RT[.X<RTEF>]<ARTEF> EQL .VREG THEN CLEARONE(RT[.X<RTEF>]);
DULEX(.X);
H_LOCATE(IDFTDC,0);
IDREG_LITV(.IDREGLEXEME) AND #17;
AOJSOJCASE_
IF (LITERALBY_LITP(.BYLEXEME)) THEN
BEGIN
BYVALUE_LITV(.BYLEXEME);
(ADDONECASE_.BYVALUE EQL 1) OR (.BYVALUE EQL -1)
END;
SFORLABEL_1;
IF .LITERALBY THEN
IF .AOJSOJCASE THEN
(OPCODE_
BEGIN REGISTER TOVALUE;
IF LITP(.TOLEXEME) THEN
BEGIN
TOVALUE_LITV(.TOLEXEME);
IF .TOVALUE EQL 0 THEN
EXITBLOCK
IF .N EQL .ADDONECASE THEN SOJGE ELSE AOJLE;
IF .TOVALUE EQL 1 THEN
IF .N EQL .ADDONECASE THEN EXITBLOCK SOJG;
IF .TOVALUE EQL -1 THEN
IF .N NEQ .ADDONECASE THEN EXITBLOCK AOJL;
END;
IF .N EQL .ADDONECASE THEN SOJA ELSE AOJA
END;
CODE(.OPCODE,.IDREG,LABLE(LOCATE(IDFTDC,2)),0))
ELSE
BEGIN
IF SMPOSLITVP(.BYVALUE) THEN
CODE(IF .N THEN SUBI ELSE ADDI,.IDREG,.BYVALUE,0) ELSE
IF SMNEGLITVP(.BYVALUE) THEN
CODE(IF .N THEN ADDI ELSE SUBI,.IDREG,-.BYVALUE,0)
ELSE
CODE(IF .N THEN SUB ELSE ADD,.IDREG,LITA(.BYLEXEME),0);
GUJUMP(LOCATE(IDFTDC,2))
END
ELSE
BEGIN
CODE(IF .N THEN SUB ELSE ADD,.IDREG,GMA(GAT(.BYLEXEME)),0);
GUJUMP(LOCATE(IDFTDC,2))
END;
SFORLABEL_0;
ACPR1(); ! --> 3
LOSECONV();
PROMOTE(1^RELC OR 1^XLOOPC);
ACPR1(); ! --> 4
CLASSLAB(); ! --> 5
PUSHCODE(); ! --> \5
X_CONVEY(LITLEXEME(-1));
ACPR2(); ! --> 6
CLASSLAB(); ! --> 0
IF .DROPBODY THEN DROP(1^2 OR 1^3 OR 1^4 OR 1^6);
UNTEMPLATE();
.X
END;
%
IF-THEN-ELSE
IF E1 THEN E2 ELSE E3
^ ^ ^ ^
^ ^ ^ ^
GITE0() -------------^ ^ ^ ^
^ ^ ^
GITE1(E1) --------------^ ^ ^
^ ^
GITE2(E2) ----------------------^ ^
^
GITE3(E3) ------------------------------^
SKELETON
0 ITE
1 IF
2 THEN
3 LABEL
4 ELSE
5 LABEL
%
GLOBAL ROUTINE GITE0=
% IF HAS BEEN MET COMMENCING AN IF-THEN-ELSE. %
BEGIN
TEMPLATE(1,ITEC,5); ! --> 0
ACPDT(); ! --> 1
PUSHCODE(); ! --> \1
END;
MACRO GCASEJMP(DEST)=
CODE(JRST,0,(DEST) OR CASEJMPRELOC^30,0)$;
ROUTINE GSUJUMP(X,J)=
% THIS ROUTINE GENERATES A JRST INSTRUCTION FOLLOWING
THE 'BOOLEAN' PART OF AN IFSKIP. CALL DULEX(.X)
SINCE WE REALLY DON'T NEED THE VALUE OF THE EXPRESSION.
THE JRST IS FLAGGED AS A CASE JUMP TO PREVENT
FLATFUNC FROM OPTIMIZING IT AWAY. %
BEGIN
IF .FREEVHEADER LSS 0 THEN
BEGIN
FREEVHEADER_FOLLCPH(0,CODEC,0);
FOLLCPH(0,CODEC,0)
END;
DULEX(.X);
GCASEJMP(.J)
END;
GLOBAL ROUTINE GITE1(X,TOG)=
% IF CLAUSE COMPLETED WITHIN IF-THEN-ELSE. %
!TOG=0 --> IF, TOG=1 --> IFSKIP
!THE MANIPULATION HERE FOR POSTPONING THE CALL ON FREEVREG IS
!TO INSURE OPTIMAL CODE GENERATION FOR THE CASES "IF 0" AND "IF 1"
BEGIN
FREEVHEADER_-1;
IF .TOG
THEN GSUJUMP (.X,LOCATE(ITEC,3))
ELSE GCUJUMP (.X,LOCATE(ITEC,3),0,1);
ACPR1(); ! --> 1
PROMOTE(1^CNVEYC OR 1^RELC);
CODEPTR_.FREEVHEADER;
FREEVREG();
CODEPTR_LOCATE(ITEC,2); ! --> 2
FREEVHEADER_0;
PUSHCODE(); ! --> \2
END;
GLOBAL ROUTINE GITE2(X)=
% THEN CLAUSE COMPLETED WITHIN AN IF-THEN-ELSE. %
BEGIN REGISTER CNVYIND,MUSTPROMOTE,I;
CONVEY(.X);
ACPR1(); ! --> 2
PROMOTE(1^RELC OR 1^XCONDC);
!!!THE FOLLOWING 9 LINES OF CODE ARE NECESSARY TO INSURE THAT WE
!!!DO NOT BUILD A EMPTY THEN CLAUSE.
I_.CT[.CODEPTR,1]<NEXTF>; MUSTPROMOTE_0;
UNTIL .I EQL .CODEPTR DO
BEGIN
IF NOT (NULL(.I) OR ALLNOS(.I)) THEN
IF .CT[.I,0]<CLASSF> EQL CODEC THEN EXITLOOP(MUSTPROMOTE_0)
ELSE IF .CT[.I,0]<CLASSF> EQL CNVEYC THEN (CNVYIND_.I; MUSTPROMOTE_1);
I_.CT[.I,0]<NEXTF>
END;
IF .MUSTPROMOTE THEN CT[.CNVYIND,0]<CLASSF>_CODEC;
ACPDB(); ! --> \2
GUJUMP(LOCATE(ITEC,5));
ACPR2(); ! --> 3
CLASSLAB(); ! --> 4
PUSHCODE(); ! --> \4
END;
GLOBAL ROUTINE GITE3(X)=
% ELSE CLAUSE COMPLETED WITHIN AN IF-THEN-ELSE. %
BEGIN
X_CONVEY(.X);
ACPR1(); ! --> 4
PROMOTE(1^RELC OR 1^XCONDC);
ACPR1(); ! --> 5
CLASSLAB(); ! --> 0
UNTEMPLATE();
.X
END;
%
CASE-OF-SET-TES
CASE E1, ... ,EN OF SET S1; ... ;SM TES
^ ^ ^ ^ ^
GCOST0()-------^ ^ ^ ^ ^
^ ^ ^ ^
GCOST1(E1)----------^ ^ ^ ^
^ ^ ^
GCOST2(EN,N)------------------^ ^ ^
^ ^
GCOST3(S1)-----------------------------^ ^
^
GCOST4(SM)----------------------------------------^
SKELETONS:
SINGLE-SELECTOR: MULTI-SELECTOR:
0 COST 0 COST
0.2 NOT USED 0.2 COUNTREG INFO.
0.3 BOOLEAN:MULTI-SEL 0.3 BOOLEAN:MULTI-SEL
1 SELECTOR 1 SELECTOR SET
2 NOT-USED 2 REGS OF SELECTORS/LABEL
3 INDIRECT JUMP 3 INDIRECT JUMP
4 LABEL 4 LABEL
5 JUMP TABLE 5 JUMPTABLE
6 SET-TES 6 SET-TES
7 LABEL 7 LABEL
SET ELEMENT: SET ELEMENT:
0 SET 0 SET
1 LABEL 1 LABEL
2 SET CODE 2 SET CODE
3 LABEL
4 AOJA
%
MACRO MULTISELECTOR=CT[.H,3]$,
COUNTREGADDR=CT[.H,2]<RIGHTF>$,
COUNTREGNAME=CT[.H,2]<LEFTF>$;
! TO HELP IN FOLLOWING THESE ROUTINES FOR THE CASE STATEMENT, WE
! INCLUDE SAMPLE CODE FOR THE TWO TYPES:
!
! A_CASE .B OF SET .B+.C; F(); 3; G(.E) TES
!
!
! MOVE 04,B
! XCT $S,L1426(04)
! JRST $S,L1230
! L1426: JRST $S,L1414
! PUSHJ $S,F
! MOVEI $V,3
! JRST $S,L1446
! L1414: ADD 04,C
! MOVE $V,4
! JRST $S,L1230
! L1446: PUSH $S,E
! PUSHJ $S,G
! SUB $S,[000001,,000001]
! L1230: MOVEM $V,A
!
!
! A_CASE .B,.C+.D,F() OF SET G(); .A*.B; .D*F(.A) TES
!
!
! MOVE 04,B
! MOVEM 04,1($F)
! MOVE 05,D
! ADD 05,C
! MOVEM 05,2($F)
! PUSHJ $S,F
! MOVEM $V,3($F)
! SETOM $S,4($F)
! MOVEI 06,1($F)
! L1260: MOVE 07,0(06)
! JRST $S,@L1322(07)
! JRST $S,L1420
! L1322: JRST $S,L1306
! JRST $S,L1356
! JRST $S,L1360
! L1306: MOVEM 06,5($F)
! PUSHJ $S,G
! MOVE 06,5($F)
! AOJA 06,L1260 ^^^
! L1356: MOVE $V,B
! IMUL $V,A
! AOJA 06,L1260 ^^^
! L1360: PUSH $S,A
! MOVEM 06,6($F)
! PUSHJ $S,F
! SUB $S,[000001,,000001]
! IMUL $V,D
! MOVE 06,6($F)
! AOJA 06,L1260 ^^^
! L1420: MOVEM $V,A
GLOBAL ROUTINE GCOST0=
! CASE HAS BEEN MET COMMENCING CASE-OF-SET-TES
BEGIN
TEMPLATE(2,COSTC,7); ! --> C0
ACPDT(); ! --> C1
PUSHCPH(SELELC); ! --> SLC
CT[.CODEPTR,1]<HDRCLASSF>_#40;
PUSHCODE() ! --> \SLC
END;
ROUTINE SINGINSTP(H)=
!USED TO TEST IF CODE HANGING FROM CT[.H,0] CONTAINS ONLY ONE
!INSTRUCTION. PREDICATE IS TRUE IFF RIGHT HALF OF RETURNED VALUE IS A 1.
!IF TRUE, THE LEFT HALF CONTAINS INDEX OF THE INSTRUCTION.
BEGIN REGISTER C,I;
C_0;
I_.CT[.H,1]<NEXTF>;
UNTIL .I EQL .H DO
BEGIN
IF .CT[.I,0]<HDRF> THEN C_.C+SINGINSTP(.I)
ELSE IF .CT[.I,1]<FUNCF> NEQ 0 THEN C_.C+(.I^18 OR 1);
IF .C<RIGHTF> GTR 1 THEN BREAK ELSE I_.CT[.I,0]<NEXTF>
END;
.C
END;
GLOBAL ROUTINE GCOST1(E)=
! COMMA ENCOUNTERED IN THE SELECTOR LIST OF A MULTI-SEL CASE STATEMENT
BEGIN
SGC12(.E);
PUSHCPH(SELELC); ! --> SLC
CT[.CODEPTR,1]<HDRCLASSF>_#40;
PUSHCODE() ! --> \SLC
END;
ROUTINE SGC12(E)=
!SUBROUTINE CALLED FROM GCOST1 AND GCOST2 TO PUT REGISTER ADDRESS
!FOR EACH ELEMENT OF SELECTOR LIST ON COSTC #2. CALLED ONLY WHEN
!COMPILING A MULTISELECTOR CASE STATEMENT.
BEGIN
E_GLAR(.E);
ACPR1(); ! --> SLC
PROMOTE(1^CNVEYC OR 1^RELC);
ACPR1(); ! --> C1
CT[NEWBOT(LOCATE(COSTC,2),1),1]_.RT[.E<RTEF>]<ARTEF>;
DULEX(.E)
END;
GLOBAL ROUTINE GCOST2(E,N)=
! OF ENCOUNTERED IN SINGLE (N=1) OR MULTI (N>1) SELECTOR CASE STATEMENT
BEGIN
REGISTER H, ! INDEX OF COSTC HEADER
I, ! TEMP FOR INDEXING THRU LIST
J, ! " " " " "
R; ! MULTI-NAMED REGISTER
LOCAL P, ! TEMP INDEX HOLDER
LOCBASE;! FIRST ALLOCATED LOCAL OF CONTIGUOUS CHUNK
MACRO L=R$, ! TEMP FOR LOCAL LEXEMES
COUNTINGREG=R$, ! ADDRESS OF COUNTING REG(MULTISELECTOR)
INDEXREG=R$; ! ADDRESS OF INDEX REGISTER FOR JUMPS
H_LOCATE(COSTC,0);
IF .N EQL 1 THEN
BEGIN
E_GLAR(.E);
ACPR1(); ! --> SLC
PROMOTE(1^CNVEYC OR 1^RELC);
SYPHON(I_.CODEPTR);
ACPR3(); ! --> C3
RELEASESPACE(TAKE(.I),1);
PUSHCODE();
%4.11% IF NOT (.NPTFLG) THEN
%4.01% CODE(PEEPHOLE,0,PEEPOFF,0);
CODE(XCT,0,LABLE(MADRIR(.E,LOCATE(COSTC,4))),0);
GCASEJMP(LOCATE(COSTC,7));
END
ELSE
BEGIN
MULTISELECTOR_1;
SGC12(.E);
I_.CT[.CODEPTR,1]<NEXTF>;
J_.CT[LOCATE(COSTC,2),1]<NEXTF>;
!! THIS LOOP GENERATES CODE TO STORE EACH SELECTOR RESULT INTO A
!! LOCAL. THIS WILL RESULT IN A CHUNK (N+1) OF LOCALS WITH
!! THE N SELECTOR VALUES AND THE LAST CONTAINING A -1 SO THAT
!! WHEN THE LIST IS EXHAUSTED CONTROL PASSES TO THE END OF THE
!! CASE STATEMENT
INCR K FROM 1 TO .N DO
BEGIN
CODEPTR_.CT[.I,1]<PREVF>; ! --> SLC
L_GENLOCAL();
IF .K EQL 1 THEN LOCBASE_.L;
CODE(MOVEM,.CT[.J,1],GMA(GAT(.L)),0);
SYPHON(P_.I);
I_.CT[.I,0]<NEXTF>;
J_.CT[.J,0]<NEXTF>;
RELEASESPACE(TAKE(.P),1)
END;
CODEPTR_.CT[.CT[.H,1]<NEXTF>,1]<PREVF>; ! --> \C1
CODE(SETOM,0,GMA(GAT(GENLOCAL())),0);
CODE(MOVEI,COUNTINGREG_ACQUIRE(-1,1),GMA(GAT(.LOCBASE)),0);
COUNTREGADDR_.COUNTINGREG;
COUNTREGNAME_.ART[.COUNTINGREG]<RTEF>;
ACPR2(); ! --> C2
EMPTY(.CODEPTR);
CLASSLAB(); ! --> C3
PUSHCODE(); ! --> \C3
%4.11% IF NOT (.NPTFLG) THEN
%4.01% CODE(PEEPHOLE,0,PEEPOFF,0);
CODE(MOVE,INDEXREG_ACQUIRE(-1,1),.COUNTREGADDR^18,0);
GUJUMP(MADRIR(LEXRA(.INDEXREG),LOCATE(COSTC,4)));
CT[.CT[.CODEPTR,1]<PREVF>,1]<INDRF>_1;
GCASEJMP(LOCATE(COSTC,7));
END;
CODEPTR_LOCATE(COSTC,1); ! --> C1
PUSHCODE(); ! --> \C1
RT[.COUNTREGNAME]<RSF>_1;
FREEVREG();
RT[.COUNTREGNAME]<RSF>_0;
CODEPTR_LOCATE(COSTC,4); ! --> C4
CLASSLAB(); ! --> C5
PUSHCODE(); ! --> \C5
ACPR2(); ! --> C6
PUSHCPH(CURRENTC); ! --> CTC
CT[.CODEPTR,1]<HDRCLASSF>_#40;
IF .N EQL 1 THEN PUSHSET() ELSE PUSHMSET()
END;
ROUTINE PUSHMSET=
! CREATES A SETC ELEMENT IN A MULTI-SEL CASE STATEMENT
BEGIN
CODEPTR_PUSHBOT(.CODEPTR,SKELETON(1,SETC,4)); ! --> MS0
ACPDT(); ! --> MS1
CLASSLAB(); ! --> MS2
PUSHCODE() ! --> \MS2
END;
ROUTINE PUSHSET=
! CREATS A SETC ELEMENT IN A SINGLE-SEL CASE STATEMENT
BEGIN
CODEPTR_PUSHBOT(.CODEPTR,SKELETON(1,SETC,2)); ! --> S0
ACPDT(); ! --> S1
CLASSLAB(); ! --> S2
PUSHCODE(); ! --> \S2
END;
GLOBAL ROUTINE GCOST3(S)=
% A SET ELEMENT HAS BEEN COMPLETED IN A CASE STATEMENT. %
BEGIN
SGC34(.S,0)
END;
ROUTINE SGC34(S,LAST)=
! SUBROUTINE CALLED BY GCOST3 (LAST=0) AND GCOST4 (LAST=1). IN THE
! SINGLE SELECTOR CASE IT ATTEMPTS TO PUT SINGLE INSTRUCTION SET ELEMENTS
! DIRECTLY INTO THE JUMP TABLE
BEGIN
REGISTER H, ! INDEX OF COSTC HEADER
ONEIND, ! INDEX OF INST. WHERE SET ELEMENT COMPILES TO ONE INSTRUCTION
ONERELOC; ! RELOCATION TYPE FOR ONE-INSTRUCTION CASE
LOCAL SETLABEL, ! INDEX OF MOST RECENT SET-ELEMENT'S LABEL
ONECODE, ! ONE-INSTRUCTION ITSELF
ONEINST, ! BOOLEAN INDICATING ONE-INSTRUCTION
H1; ! TEMP FOR INDEX
H_LOCATE(COSTC,0);
SETLABEL_.CT[.CT[.CODEPTR,0]<NEXTF>,0]<PREVF>;
S_CONVEY(.S);
IF NOT .MULTISELECTOR THEN
BEGIN
ONEIND_SINGINSTP(.CT[.CODEPTR,0]<NEXTF>);
IF .ONEIND<RIGHTF> EQL 1 THEN
BEGIN ONEIND_.ONEIND<LEFTF>; ONEINST_1 END ELSE
IF .ONEIND EQL 0 THEN
BEGIN
GUJUMP(LOCATE(COSTC,7));
ONEIND_.CT[.CODEPTR,1]<PREVF>;
CT[.ONEIND]<RELOCF>=CASEJMPRELOC; ! DON'T ERASE THE CODE THAT FOLLOWS THE
! JUMP **U1**
ONEINST_1
END
ELSE ONEINST_0;
IF NOT .LAST AND NOT .ONEINST THEN GUJUMP(LOCATE(COSTC,7));
ACPR1(); ! --> S2
PROMOTE(1^RELC OR 1^XCOSTC);
IF .ONEINST THEN
BEGIN
ONERELOC_.CT[.ONEIND,0]<RELOCF>;
ONECODE_.CT[.ONEIND,1];
EMPTY(.CODEPTR)
END
END
ELSE
BEGIN
ONEINST_0;
ACPR1(); ! --> MS2
PROMOTE(1^RELC OR 1^XCOSTC);
ACPR1(); ! --> MS3
CLASSLAB(); ! --> MS4
PUSHCODE(); ! --> \MS4
SFORLABEL_1;
IF .RT[.COUNTREGNAME]<RSF> THEN
RELOADTEMP(.COUNTREGADDR,.COUNTREGNAME);
CODE(AOJA,.COUNTREGADDR,LABLE(LOCATE(COSTC,2)),0);
SFORLABEL_0;
END;
IF NOT .LAST THEN DULEX(.S);
CODEPTR_LOCATE(COSTC,5); ! --> C5
ACPDT(); ! --> \C5
IF .ONEINST THEN
BEGIN
CT[H1_NEWBOT(.CODEPTR,1),0]<RELOCF>_.ONERELOC;
CT[.H1,1]_.ONECODE
END
ELSE GCASEJMP(.SETLABEL);
!! THIS INSTRUCTION IS PUT OUT AS MARKER TO FLATFUNC SO IT WILL NOT
!! ATTEMPT TO BACKOVER THE JUMP-TABLE
%4.01% IF .LAST THEN BEGIN
%4.01% CODE(#257,0,NOBORELOC^30,0);
%4.11% IF NOT (.NPTFLG) THEN
%4.01% CODE(PEEPHOLE,0,PEEPREV,0);
%4.01% END;
ACPR2(); ! --> C6
ACPDT(); ! --> \C6==CTC
IF NOT .LAST THEN IF .MULTISELECTOR THEN PUSHMSET() ELSE PUSHSET();
.S
END;
GLOBAL ROUTINE GCOST4(S)=
! THE FINAL SET ELEMENT HAS BEEN MET IN A CASE STATEMENT
BEGIN REGISTER H;
S_SGC34(.S,1);
H_LOCATE(COSTC,0);
SCAN(.CODEPTR,SETC,CLASSP,UNSKELETON);
SYPHON(.CODEPTR);
ERASE(.CODEPTR);
IF .COUNTREGADDR NEQ 0 THEN DUA(.COUNTREGADDR);
CODEPTR_.CT[.H,1]<PREVF>; ! --> C7
CLASSLAB(); ! --> C0
UNTEMPLATE();
.S
END;
%
SELECT-OF-NSET-TESN
SELECT E1, ... ,EN OF NSET L1:S1; ... :SM TESN
^ ^ ^ ^ ^ ^
GSE0 -------------^ ^ ^ ^ ^ ^
^ ^ ^ ^ ^
GSE1(E1) --------------^ ^ ^ ^ ^
^ ^ ^ ^
GSE2(EN) -------------------------^ ^ ^ ^
^ ^ ^
GSE3(L1) ----------------------------------^ ^ ^
^ ^
GSE4(S1) -------------------------------------^ ^
^
GSE5(SM) ------------------------------------------------^
SKELETONS:
0 SELECT
0.2 LEXEME OF LOCAL FOR RESULT
0.3 BOOLEAN: ALWAYS OR OTHERWISE GENERATED
1 SELECTOR CODE
2 SELECTOR LEXEME(S)
3 NSET-TESN
4 SETO CODE
5 EXIT LABEL
NSET ELEMENT:
0 NSET
1 LABEL CODE
2 LABEL
3 NSET CODE
4 LABEL
%
! AN EXAMPLE OF THE CODE FOR A SELECT STATEMENT FOLLOWS:
!
!
! A_SELECT .B,0,2 OF NSET .D:F(.E); .E:0 TESN
!
!
! MOVE 04,B
! MOVEM 04,1($F)
! SETOM $S,2($F)
! MOVE 05,D
! CAMN 05,1($F)
! JRST $S,L1276
! JUMPE 05,L1276
! CAIE 05,2
! JRST $S,L1316
! L1276: AOS $S,2($F)
! PUSH $S,E
! PUSHJ $S,F
! SUB $S,[000001,,000001]
! L1316: MOVE 06,E
! CAMN 06,1($F)
! JRST $S,L1334
! JUMPE 06,L1334
! CAIE 06,2
! JRST $S,L1256
! L1334: AOS $S,2($F)
! SETZ $V,0
! L1256: SKIPGE $S,2($F)
! SETO $V,0
! MOVEM $V,A
MACRO MINUSONELOCAL=CT[LOCATE(SELECTC,0),2]$;
!LEXEME OF LOCAL USED TO DETERMINE IF A NSET ELEMENT HAS BEEN EXECUTED
GLOBAL ROUTINE GSE0=
! SELECT MET COMMENCING A SELECT-OF-NSET-TESN
%4.01% BEGIN LOCAL TEMP;
FREEVREG();
TEMPLATE(2,SELECTC,5); ! --> S0
ACPDT(); ! --> S1
PUSHCPH(CURRENTC); ! --> CTC
CT[.CODEPTR,1]<HDRCLASSF>_#40;
% 9-21-77
4.11 IF NOT (.NPTFLG) THEN
4.11 BEGIN
4.01 TEMP_.CODEPTR;
4.01 PUSHCODE();
4.01 CODE(PEEPHOLE,0,PEEPOFF,0);
4.01 CODEPTR_.TEMP;
4.11 END;
%
PUSHCODE() ! --> \CTC
END;
ROUTINE SGSE12(E)=
! SUBROUTINE CALLED FROM GSE1 AND GSE2 TO HANG LEXEME OF SELECTOR
!ELEMENT FROM SELECTC #2
BEGIN LOCAL H,LEX,V;
H_LOCATE(SELECTC,2);
IF NOT (IF LITP(.E) THEN (V_LITV(.E);SMPOSLITVP(.V))) THEN
(LEX_GENLOCAL();DULEX(GSTO(.LEX,.E)))
ELSE LEX_.E;
CT[NEWBOT(.H,1),1]_.LEX
END;
GLOBAL ROUTINE GSE1(E)=
! COMMA MET IN SELECTOR LIST OF SELECT-OF-NSET-TESN
BEGIN
SGSE12(.E);
ACPR1(); ! --> CTC
PROMOTE(1^CNVEYC OR 1^RELC);
SYPHON(.CODEPTR);
PUSHCODE() ! --> \CTC
END;
GLOBAL ROUTINE GSE2(E)=
! OF MET IN SELECT EXPRESSION. GENERATES LOCAL LEXEME TO BE USED
! TO CHECK IF ANY NSET-TESN ELEMENT IS EXECUTED
BEGIN LOCAL H,LEX;
SGSE12(.E);
LEX_GAT(GENLOCAL());
MINUSONELOCAL_.LEX;
CODE(SETOM,0,GMA(.LEX),0);
ACPR1(); ! --> CTC
PROMOTE(1^CNVEYC OR 1^RELC);
SYPHON(H_.CODEPTR);
ACPR3(); ! --> C3
ERASE(.H);
PUSHCPH(CURRENTC); ! --> CTC
CT[.CODEPTR,1]<HDRCLASSF>_#40;
PUSHNSET()
END;
ROUTINE PUSHNSET=
! CREATE A NSET ELEMENT
BEGIN
CODEPTR_PUSHBOT(.CODEPTR,SKELETON(1,NSETC,4)); ! --> NS0
ACPDT(); ! --> NS1
PUSHCODE() ! --> \NS1
END;
GLOBAL ROUTINE GSE3(E)=
! A COLON ENCOUNTERED IN A SELECT EXPRESSION. CODE IS GENERATE TO
! CHECK SELECTOR LIST AGAINST VALUE OF LABEL.
BEGIN LOCAL LAB1,LAB2,RLEX; REGISTER I;
LAB1_LABLE(LOCATE(NSETC,2));
LAB2_LABLE(LOCATE(NSETC,4));
E_REGAK(RLEX_GLAR(.E));
I_.CT[LOCATE(SELECTC,2),1]<NEXTF>;
UNTIL LAST(.I) DO
BEGIN
SGSE3(.CT[.I,1],.LAB1,.E,0);
I_.CT[.I,0]<NEXTF>
END;
SGSE3(.CT[.I,1],.LAB2,REGAR(.RLEX),1);
ACPR1(); ! --> NS1
PROMOTE(1^RELC OR 1^CNVEYC);
ACPR1(); ! --> NS2
CLASSLAB(); ! --> NS3
PUSHCODE(); ! --> \NS3
CODE(AOS,0,GMA(.MINUSONELOCAL),0)
END;
ROUTINE SGSE3(LEX,LAB,REG,LAST)=
! SUBROUTINE CALLED BY GSE3 TO GENERATE TEST (VS. LEX) AND
! JUMP TO LAB. LAST INDICATES THAT LEX IS THE LAST
! SELECTOR ON THE LIST.
BEGIN REGISTER V;
IF(IF LITP(.LEX) THEN
(V_LITV(.LEX);SMPOSLITVP(.V))) THEN
IF .V EQL 0 THEN
CODE(JUMPE+4*.LAST,.REG,.LAB,0)
ELSE
BEGIN
CODE(CAIN-4*.LAST,.REG,.V,0);
CODE(JRST,0,.LAB,0)
END
ELSE
BEGIN
CODE(CAMN-4*.LAST,.REG,GMA(GAT(.LEX)),0);
CODE(JRST,0,.LAB,0)
END
END;
GLOBAL ROUTINE GSE3O=
! OTHERWISE ENCOUNTERED AS A LABEL
BEGIN
CT[LOCATE(SELECTC,0),3]_-1;
CODE(AOSE,0,GMA(.MINUSONELOCAL),0);
CODE(JRST,0,LABLE(LOCATE(NSETC,4)),0);
ACPR3(); ! --> NS3
PUSHCODE() ! --> \NS3
END;
GLOBAL ROUTINE GSE3A=
! ALWAYS ENCOUNTERED AS A LABEL
BEGIN
CT[LOCATE(SELECTC,0),3]_-1;
ACPR3(); ! --> NS3
PUSHCODE(); ! --> \NS3
CODE(AOS,0,GMA(.MINUSONELOCAL),0)
END;
GLOBAL ROUTINE GSE4(E)=
! NSET ELEMENT COMPLETED IN A SELECT EXPRESSION
BEGIN
DULEX(CONVEY(.E));
ACPR1(); ! --> NS3
PROMOTE(1^RELC OR 1^XSELECTC);
ACPR1(); ! --> NS4
CLASSLAB(); ! --> NS0
ACPR1(); ! --> CTC
PUSHNSET()
END;
GLOBAL ROUTINE GSE5(E)=
! LAST NSET ELEMENT ENCOUNTERED IN SELECT EXPRESSION. IF E=0, THEN
! WE HAVE THE CASE WHERE THE LAST ELEMENT IS MISSING. E.G.:
! SELECT .A OF NSET .B:.C; .D:.E; TESN
! IF NO ALWAYS OR OTHERWISE LABELS WERE GENERATED, THEN THE -1 VALUE
! IS CONVEYED
BEGIN LOCAL I;
EMPTY(LOCATE(SELECTC,2));
IF .E EQL 0 THEN CODEPTR_LOCATE(NSETC,4) ! --> NS4
ELSE
BEGIN
E_CONVEY(.E);
ACPR1(); ! --> NS3
PROMOTE(1^RELC OR 1^XSELECTC);
ACPR1() ! --> NS4
END;
CLASSLAB(); ! --> NS0
ACPR1(); ! --> CTC
SCAN(.CODEPTR,NSETC,CLASSP,UNSKELETON);
%4.01% I_.CODEPTR;
% 6-24-77 DO NOT DELETE A CELL BECAUSE THE CODE IS
BAD FOR SELECT . X OF NSET 1:RETURN 1; OTHERWISE: RETURN 0
TESN;
4.11 IF NOT (.NPTFLG) THEN
4.11 BEGIN
4.01 PUSHCODE();
4.01 CODE(PEEPHOLE,0,PEEPREV,0);
4.01 CODEPTR_.I;
4.11 END;
%
%4.01% SYPHON(.I);
ACPR2(); ! --> S4
ERASE(.I);
IF NOT .CT[LOCATE(SELECTC,0),3] THEN
BEGIN
PUSHCODE(); ! --> \S4
CODE(SKIPGE,0,GMA(.MINUSONELOCAL),0);
CODE(SETO,.VREG,0,0);
ACPR2(); ! --> S5
END
ELSE ACPR1(); ! --> S5
CLASSLAB(); ! --> S0
UNTEMPLATE();
IF .E EQL 0 THEN GETVREG() ELSE .E
END;
%
FUNCTION-ROUTINE CALL
E0(E1,EM)
^ ^
GFRC1(E1)____________^ ^
^
GFRC2(EM,E0,M)__________^
%
GLOBAL ROUTINE GFRC1(X)=
! A PARAMETER (NOT THE LAST) HAS BEEN COMPLETED
BEGIN
PCIVR(.X,0);
REGSEARCH(X,0);
CODE(PUSH,.SREG,MEMORYA(.X),0)
END;
% COROUTINES.
- - - - GENERAL FORMAT - - - -
THE STACK OF A COROUTINE INSTANCE CONSISTS OF A STATE AREA WITH A NORMAL STACK ON TOP.
THE STATE AREA AND LOWER PART OF STACK DESCRIBED BELOW. NOTE THAT THE LOWEST 'RETURN
ADDRESS' IS REPLACED BY THE ADDR. OF THE THEN-PART OF THE APPROPRIATE CREATE-EXPR., AND
THE ORIGINAL CONTENTS OF THE F-REG IS THAT OF THE CREATOR.
STATE AREA:
THE LAYOUT OF THE STATE AREA IS:
! !
! ! ^ NORMAL STACK AS DESCRIBED IN MANUAL. ^
! !
!------------!
!THEN ADDRESS! ADDR. OF THEN-PART OF CREATE (IN RETURN ADDR. POSITION).
!------------!
!LAST ACTUAL !
!-- --!
! ! THIS AREA OMITTED IF NO ACTUALS.
!-- --!
!1'ST ACTUAL !
!------------!
! SAVE AREA !
! FOR ALL ! THIS AREA OMITTED IF /R OPTION INVOKED.
! DECLARABLE !
! REGISTERS !
!------------!
2 ! F REGISTER !
!------------! THESE TWO ALWAYS SAVED AND RESTORED.
1 ! S REGISTER !
!------------!
0 ! REACTIVA- ! ADDRESS WHERE EXECUTION SHOULD RESUME.
! TION POINT !__ BASE REGISTER POINTS HERE DURING EXECUTION.
------------
REGISTERS:
ALL DECLARABLE REGISTERS, WHETHER IN USE OR NOT, ARE NORMALLY SAVED IN THE STATE AREA OF
THE NEW PROCESS DURING CREATE. THEY ARE RESTORED/SAVED WHEN THE PROCESS IS ENTERED/LEFT
BY AN EXCHJ. THE USER MAY OMIT THIS SAVING AND RESTORING BY USING THE /R SWITCH. THIS
WILL CLEAR THE "SVERGFLG" IN THE COMPILER. NO SPACE FOR THE REGISTERS IS RESERVED IN THE
STATE AREA WHEN THIS OPTION IS USED.
TEMPORARY REGISTERS ARE SAVED ACROSS EXCHJ'S IN THE STACK, AS FOR FUNCTION/ROUTINE CALLS.
- - - - CREATE: - - - -
THE SEQUENCE OF EVALUATIONS AND EVENTS DURING
CREATE E1(ELIST) AT E2 LENGTH E3 THEN E4
WILL BE:
E2, E3, ELIST IN SEQUENCE, E1, REGISTERS SAVED IN NEW STATE.
HOWEVER, IF E1 IS NOT A NAME IT WILL BE EVALUATED BEFORE E2.
THE THEN - PART:
DURING THE EVALUATION OF E4 THE VALUES OF THE RUN-TIME REGISTERS ARE AS FOR THE OUTMOST
LEVEL OF THE PROCESS THAT RETURNED, EXEPT THAT THE F-REGISTER IS AS FOR THE PROCESS THAT
CREATED THE ONE WHICH IS NOW RETURNING. HENCE USE OF LOCAL VARIABLES IN E4 WILL USUALLY
BE MEANINGFULL. E4 IS TERMINATED BY A HALT INSTRUCTION, WITH THE VALUE OF E4 IN THE
VALUE-REGISTER.
VALUE OF CREATE:
IF THE INSPECT OPTION (/I) IS USED, THE VALUE OF A CREATE IS:
--------- --------- ------------------
^ RAFL ^ RALF ^ BASE ADDRESS ^
--------- --------- ------------------
0 8 9 17 18 35
WHERE:
RAFL = RELATIVE ADDRESS OF FIRST LOCAL
RALF = RELATIVE ADDRESS OF LAST FORMAL
BOTH RELATIVE TO THE BASE ADDRESS, AND TAKING INTO ACCOUNT THAT THE NO. OF ACTUALS MAY
DIFFER FROM THE NO. OF FORMALS. IF THE INSPECT OPTION IS NOT USED, RAFL AND RALF ARE
ZERO, THEY WILL ALSO BE ZERO IF THERE ARE NO LOCALS OR ACTUALS.
THE INSPECT WORD.
THE SPECIAL WORD MENTIONED IN THE DESCRIPTION OF THE INSPECT- SWITCH IN THE MANUAL IS:
--------- --------- ------------------
! RAFL ! NFORM ! OBJECT SIZE !
--------- --------- ------------------
0 8 9 17 18 35
WHERE
RAFL = RELATIVE ADDRESS OF FIRST LOCAL
(RELATIVE TO THE LOCATION BELOW THE RETURN ADDRESS),
NFORM = # OF FORMALS,
OBJECT SIZE = # OF FORMALS + # OF DISPLAYS + # OF SAVED
REGISTERS + # OF LOCALS + 2.
USE OF THE /I SWITCH WILL SET THE "LUNDEFLG" IN THE COMPILER.
- - - - EXCHJ: - - - -
DURING THE EVALUATION OF
EXCHJ(<PROC>,<VAL>)
<PROC> WILL IN THE MOST GENERAL CASE BE EVALUATED BEFORE <VAL>, AND SAVED IN THE STACK.
HOWEVER, THE COMPILER TRIES TO RECOGNICE WHEN <PROC> CAN BE OBTAINED BY A SINGLE 'MOVE'
AND IS NOT LIABLE TO SIDEEFFECTS FROM <VAL>. IN SUCH CASES <VAL> WILL BE EVALUATED FIRST
AND <PROC> 'MOVE'D DIRECTLY INTO BREG WHEN NEEDED. THE COMPILER WILL FIRST GENERATE CODE
MAKING NO ASSUMPTIONS, THEN REMOVE IT IF THE OPTIMIZABLE CASE IS RECOGNIZED.
CREATE F(P1,...,PN) AT E1 LENGTH E2 THEN E3
^ ^ ^ ^ ^ ^
^ ^ ^ ^ ^ ^
GCREA0() -----------------------^ ^ ^ ^ ^ ^
^ ^ ^ ^ ^
GCREA1(PJ) --- J < N --------------^ ^ ^ ^ ^
^ ^ ^ ^
GCREA2(PN,F,N) ---------------------------^ ^ ^ ^
^ ^ ^
GCREA3(E1) ---------------------------------------^ ^ ^
^ ^
GCREA4(E2) -------------------------------------------------^ ^
^
GCREA5(E3) --------------------------------------------------------^
CREATE F(P1,...,PN) AT E1 LENGTH E2 THEN E3
^ ^ ^ ^ ^ ^
^ ^ ^ ^ ^ ^
GCREA0() -----------------------^ ^ ^ ^ ^ ^
^ ^ ^ ^ ^
GCREA1(PJ) --- J < N --------------^ ^ ^ ^ ^
^ ^ ^ ^
GCREA2(PN,F,N) ---------------------------^ ^ ^ ^
^ ^ ^
GCREA3(E1) ---------------------------------------^ ^ ^
^ ^
GCREA4(E2) -------------------------------------------------^ ^
^
GCREA5(E3) --------------------------------------------------------^
THE STACK- AND BASE REGISTERS OF CREATED PROCESS ARE SIMULATED IN
REGISTERS SP AND BP. THESE REGISTERS MAY BE SAVED BY THE PARAMETER
CODE, IN WHICH CASE THEY ARE RELOADED BY THESE ROUTINES.
SKELETON
O CREATC
0.2 REGISTER SIMULATING SREG, AS XWD NAME,ADDRESS.
0.3 REGISTER SIMULATING BREG, AS XWD NAME,ADDRESS.
1 CODE TO BUILD SP,BP FROM E1,E2.
2 CODE FOR F(P1,...,PN), STATE AREA, RAFL.
3 LABEL FOR <RAFL> = 0
4 CODE FOR <RALF> AND VALUE.
5 LABEL
6 CODE FOR E3
7 LABEL
%
GLOBAL ROUTINE GCREA0 =
%_SET UP TEMPLATE AND ACQUIRE REGISTERS FOR SP AND BP
READY TO RECEIVE CODE FOR FUNCTION/ROUTINE NAME AND PARAMETERS.
CODEPTR AT \2 ON EXIT.
_%
BEGIN
LOCAL H;
TEMPLATE(2,CREATC,7);
ACPDT(); ! --> 1;
H _ .CT[.CODEPTR,0]<PREVF>;
PUSHCODE(); !--> \1;
! SAVE IDENTITY OF SP, BP AS XWD NAME,ADDRESS.
CT[.H,2] _ ACQUIRE(-1,1); CT[.H,3] _ ACQUIRE(-1,1);
CT[.H,2]<LEFTF> _ .ART[.CT[.H,2]]<RTEF>;
CT[.H,3]<LEFTF> _ .ART[.CT[.H,3]]<RTEF>;
ACPR2(); ! -->2
PUSHCODE(); ! -->\2
END; ! END OF GCREA0.
GLOBAL ROUTINE GCREA1(P) =
%_GENERATE CODE FOR PARAMETERS EXEPT LAST.
CODEPOINTER AT \2 THROUGHOUT.
_%
BEGIN
LOCAL H;
PCIVR(.P,0);
! RELOAD SP IF NECESSARY.
H _ LOCATE(CREATC,0);
IF .RT[.CT[.H,2]<LEFTF>]<RSF>
THEN RELOADTEMP(.CT[.H,2]<RIGHTF>,.CT[.H,2]<LEFTF>);
REGSEARCH(P,0);
CODE(PUSH,.CT[.H,2]<RIGHTF>,MEMORYA(.P),0);
END; ! END OF GCREA1.
GLOBAL ROUTINE GCREA2(P,F,M) =
%_P IS PARAMETER LEXEME,
F IS FUNCTION/ROUTINE LEXEME,
M IS # OF PARAMETERS.
PUSH DOWN LAST PARAMETER, THEN PUT RETURN POINT, S-REGISTER, F-REGISTER,
DECLARABLE REGISTERS, REACTIVATION POINT INTO STATE AREA. IF THE
INSPECTION FEATURE IS USED, GENERATE CODE TO COMPUTE CORRECT RAFL AND
RALF FIELDS. -->\2 ON ENTRY; -->\1 ON EXIT.
_%
BEGIN
LOCAL K,RETLEX;
REGISTER H;
MACRO SP = (.H)<RIGHTF>$,
BP = (.H+1)<RIGHTF>$;
H _ CT[LOCATE(CREATC,0),2]<0,0>; ! ADDR OF SP,BP IS NOW .SP, .BP.
IF .M NEQ 0 THEN GCREA1(.P); ! CODE FOR LAST PARAMETER.
! RELOAD BP IF NECESSARY.
IF .RT[.(.H+1)<LEFTF>]<RSF> THEN
RELOADTEMP(.BP,.(.H+1)<LEFTF>);
! NOW INITIALIZE STATE AREA.
%3.38% CODE(PUSH,.SP,COPTR(0,0,LABLE(LOCATE(CREATC,5))),0); ! RETURN ADDR.
CODE(MOVEM,.SP,.BP^18 OR 1,0); ! SAVE PROCESS SREG
CODE(HRRZM,.FREG,.BP^18 OR 2,0); ! SAVE PROCESS FREG.
CODE(HRRZI,.SP,GMA(GAT(.F)),0);
CODE(MOVEM,.SP,.BP^18,0); ! SAVE REACTIVATION POINT.
IF .SVERGFLG THEN
! NOW CODE TO SAVE ALL DECLARABLE REGISTERS IN PROCESS STATE.
( K _ 2;
INCR I FROM 0 TO 15 DO
IF (.SVREGM AND 1^.I) NEQ 0 THEN
CODE(MOVEM,.I,.BP^18 OR (K _ .K+1),1);
);
! K NOW HOLDS SIZE OF STATEAREA - 1.
! NOW CODE TO SET RALF, RAFL FIELDS AND TRANSMIT VALUE OF CREATE.
RETLEX _ GETVREG();
IF .LUNDEFLG THEN
! YES, RALF/RAFL MUST BE CALCULATED.
( K _ .M + 2 + (IF .SVERGFLG THEN .NOSVR ELSE 0);
! K NOW HOLDS REL. ADDR. OF FIRST 'PSEUDO LOCAL'.
CODE(LDB,.VREG,LITA(LITLEXEME(#331100777777 OR .SP^18)),1);
! NOW RAFL FROM SPECIAL WORD IN CODE IS IN VREG.
CODE(JUMPE,.VREG,LABLE(LOCATE(CREATC,3)),1); ! JUMP IF RAFL = 0.
CODE(ADDI,.VREG,.K,0); ! ADD SIZE OF STATE+PARAMETERAREA.
CODE(LSH,.VREG,9,0);
! NOW MOVE PAST LABEL.
ACPR2(); CLASSLAB(); PUSHCODE(); ! -->3; -->4; -->\4;
IF .M NEQ 0 THEN CODE(IORI,.VREG,.K,0); ! OR IN RALF.
! NOW FINISH THE VALUE.
CODE(LSH,.VREG,18,0);
CODE(IOR,.VREG,.BP,0); ! OR IN BASE ADDR. FROM BR.
)
ELSE
! NO, RAFL/RALF NOT WANTED.
( CODE(MOVE,.VREG,.BP,0);
%3.38% ACPR2(); CLASSLAB(); PUSHCODE(); ! -->3; -->4; -->\4;
);
! NOW CODE TO JUMP PAST THEN PART.
CODE(JRST,0,LABLE(LOCATE(CREATC,7)),1);
! FIRST CLASSIFY THEN-LABEL.
ACPR2(); CLASSLAB(); ! -->5; -->6;
! NOW BE READY TO RECEIVE CODE FOR LOCATION AND LENGTH OF PROCESS.
CODEPTR _ LOCATE(CREATC,1); PUSHCODE(); ! -->1; -->\1;
DULEX(.RETLEX);
.RETLEX
END; ! END OF GCREA2.
GLOBAL ROUTINE GCREA3(S) =
%_COMPILE CODE TO LOAD BASE OF PROCESS INTO SIMULATED STACK REGISTER.
-->\1 THROUGHOUT.
_%
BEGIN
REGISTER H;
H _ LOCATE(CREATC,0);
! RELOAD SP IF NECESSARY.
IF .RT[.CT[.H,2]<LEFTF>]<RSF> THEN
RELOADTEMP(.CT[.H,2]<RIGHTF>,.CT[.H,2]<LEFTF>);
PCIVR(.S,0);
CODE(HRRZ,.CT[.H,2]<RIGHTF>,MEMORYA(.S),0)
END; ! END OF GCREA3.
GLOBAL ROUTINE GCREA4(S) =
%_COMPILE CODE TO LOAD NEGATIVE LENGTH OF PROCESS INTO LEFT HALF OF
SIMULATED S-REGISTER, INITIALIZE SIMULATED BASE, AND MOVE SP PAST
STATE-AREA. -->\1 ON ENTRY; -->\6 ON EXIT;
_%
BEGIN
LOCAL L,R;
REGISTER H;
MACRO SP = (.H)<RIGHTF>$,
BP = (.H+1)<RIGHTF>$;
H _ CT[LOCATE(CREATC,0),2]<0,0>; ! NOW .SP, .BP IS ADDRESS OF SP, BP.
PCIVR(.S,0);
! RELOAD SP, BP IF NECESSARY.
IF .RT[.(.H)<LEFTF>]<RSF> THEN
RELOADTEMP(.SP,.(.H)<LEFTF>);
IF .RT[.(.H+1)<LEFTF>]<RSF> THEN
RELOADTEMP(.BP,.(.H+1)<LEFTF>);
CODE(MOVN,.BP,MEMORYA(.S),1);
CODE(HRL,.SP,.BP,0);
CODE(HRRZ,RMA(.BP,0,.BP),.SP,0);
L _ (IF .SVERGFLG THEN .NOSVR ELSE 0) + 2;
CODE(ADD,RMA(.SP,0,.SP),LITA(LITLEXEME((.L)^18 OR .L)),0);
! NOW MAKE READY FOR THEN-PART.
CODEPTR _ LOCATE(CREATC,6); ! -->6.
PUSHCODE(); ! -->\6.
END; ! END GCREA4.
GLOBAL ROUTINE GCREA5(S) =
%_S IS THE THEN-PART LEXEME.
TERMINATE CODE FOR THEN-PART WITH A HALT.
CLEAN UP THE MESS. -->\6 ON ENTRY.
_%
BEGIN
DULEX(CONVEY(.S));
CODE(JRST,4,0,0);
ACPR2(); ! -->7.
CLASSLAB(); ! -->0.
UNTEMPLATE();
END; ! OF GCREA5.
% ROUTINES FOR EXCHJ.
EXCHJ(PP,VAL)
^ ^
^ ^
GEXCH0(PP) ----------------------------------^ ^
^
GEXCH1(VAL,TOG) ---------------------------------^
SKELETON:
0 EXCHC
1 CODE TO SAVE PROCESS STATE
2 PROCESS-EXPR IF NOT ONE-MOVER
3 REST OF CODE
4 LABEL - REACTIVATION POINT
_%
GLOBAL ROUTINE GEXCH0(PP) =
%_SET UP TEMPLATE, GENERATE CODE FOR STATE AND NEW BASE.
BE READY TO RECEIVE CODE FOR VALUE-EXPRESSION
VALUE RETURNED IS TRUE IF PP CAN BE PUSHED WITHOUT PREVIOUS CALCULATION.
ITS LEFTF THEN HOLDS CT-INDEX OF THAT PUSH-INSTR.
--> \3 ON EXIT.
_%
BEGIN
%3.36% EXTERNAL RBREG;
LOCAL R,ONEINSTR;
TEMPLATE(1,EXCHC,4);
ACPDT(); ! --> 1.
PUSHCODE(); ! --> \1.
%>
FIRST SAVE PROCESS STATE REGISTERS, WHICH ARE UNCHANGED ACROSS THE
PARAMETER EXPRESSIONS. THEN SET THE REACTIVATION POINT.
<%
%3.36% CODE(MOVE,BREG_ACQUIRE(-1,1),GMA(.RBREG),0);
CODE(MOVEM,.FREG,.BREG^18 OR 2,0);
CODE(MOVEM,.SREG,.BREG^18 OR 1,0);
CODE(MOVEI,R_ACQUIRE(-1,1),LABLE(LOCATE(EXCHC,4)),1);
CODE(MOVEM,RMA(.R,0,.R),.BREG^18,1);
%>
NOW PUSH NEW BASE, ASSUMING IT HAS SIDEEFFECTS ON VALUE.
<%
ACPR2(); PUSHCODE(); ! --> 2; --> \2.
CODE(PUSH,.SREG,(PP _ MEMORYA(.PP)),1);
NEXTLOCAL _ .NEXTLOCAL + 1;
DULEX(.PP);
ONEINSTR _ SINGINSTP(.CT[.CODEPTR,0]<NEXTF>); ! WAS PUSH THE ONLY INSTR. GENERATED?
ACPR2(); ! --> 3;
PUSHCODE(); ! --> \3;
.ONEINSTR
END; ! END ROUTINE GEXCH0.
GLOBAL ROUTINE GEXCH1(VAL,TOG) =
%_VAL IS LEXEME FOR VALUE-EXPRESSION.
TOG IS TRUE IF WE CAN MOVE PP DIRECTLY TO BASE REGISTER, AND ITS
LEFTF HOLDS THE CT-INDEX OF PUSH-INSTR. GENERATED BY GEXCH0.
--> \3 ON ENTRY.
_%
BEGIN
%3.36% EXTERNAL RBREG;
LOCAL R,K,MASK1,B18;
B18 _ .BREG^18; MASK1 _ 0;
VAL _ CONVEY(.VAL);
! NOW CODE TO SAVE HI-TEMPS.
INCR I FROM 16 TO 31 DO
IF .RT[.I]<USEF> NEQ 0 THEN
IF NOT (.RT[.I]<RSF>) THEN
IF (((1^(R_.RT[.I]<ARTEF>)) AND .HITREGM) NEQ 0)
OR (IF .R EQL .VREG THEN .RT[.I]<USEF> GTR 1 ELSE 0)
THEN
DUMPREG(.R);
! NOW CODE TO SAVE ALL DECLARABLES.
IF .SVERGFLG THEN
( K _ 2;
INCR I FROM 0 TO 15 DO
IF (.SVREGM AND 1^.I) NEQ 0 THEN
( MASK1 _ .MASK1 OR 1^.I;
CODE(MOVEM,.I,.B18 OR (K _ .K+1),1));
);
! NOW READY TO SWAP BASES.
IF .TOG THEN
! YES, WE MAY REPLACE THE PUSH BY A MOVE AFTER THE VALUE CALCULATION.
( R _ PUSHBOT(.CODEPTR,TAKE(.TOG<LEFTF>));
CT[.R,1]<FUNCF> _ MOVE;
CT[.R,1]<ACCF> _ .BREG)
ELSE
! NO, MUST COMPUTE PP BEFORE VAL. NOW POP IT INTO BREG.
CODE(POP,.SREG,.BREG,0);
IF .NEXTLOCAL GTR .MAXLOCAL THEN MAXLOCAL _ .NEXTLOCAL;
NEXTLOCAL _ .NEXTLOCAL - 1;
! BREG NOW CONTAINS BASE OF DESTINATION, AND WE MAY RESTORE ALL
! REGISTERS.
%3.36% CODE(MOVEM,.BREG,GMA(.RBREG),0);
CODE(MOVE,.SREG,.B18 OR 1,0);
CODE(MOVE,.FREG,.B18 OR 2,0);
IF .SVERGFLG THEN
( K _ 2;
INCR I FROM 0 TO 15 DO
IF .MASK1^(-.I) THEN
CODE(MOVE,.I,.B18 OR (K _ .K+1),1);
);
! NOW READY TO JUMP ACROSS INDIRECTLY VIA STORED REACTIVATION POINT.
CODE(JRST,0,(1^22) OR .B18,0);
%3.36% RELREG(.BREG);
ACPR1(); ! -->3.
PROMOTE(1^CNVEYC OR 1^RELC);
ACPR1(); ! --> 4
CLASSLAB(); ! --> 0
UNTEMPLATE();
SESTOG _ .SESTOG OR 4;
.VAL
END; ! END ROUTINE GEXCH1.
GLOBAL ROUTINE GSPUNOP(TYPE,PARAMETER)=
!THIS ROUTINE SERVES AS A SWITCH TO CALL THE SPECIAL-UNARY-OPERATOR
!ROUTINES
BEGIN
ROUTINE GJFFO(X)=
BEGIN
!GENERATE CODE FOR FIRSTONE(X)
BIND JFFOC=CMPEXC;
LOCAL REG,RESREG;
IF LITP(.X) THEN RETURN LITLEXEME(FIRSTONE(LITV(.X)));
PCIVR(.X,0);
REGSEARCH(X,0);
TEMPLATE(1,JFFOC,2);
ACPDT();
PUSHCODE();
CODEN(JFFO,RESREG_REGAR(REG_GLTR2(.X)),LABLE(LOCATE(JFFOC,2)),3,.X);
CODE(SETO,RESREG_.RESREG+1,0,0);
ACPR2();
CLASSLAB();
UNTEMPLATE();
LEXRA(.RESREG)
END;
ROUTINE GMOVM(X)=
!GENERATE CODE FOR ABS(X)
BEGIN LOCAL REG;
IF LITP(.X) THEN RETURN LITLEXEME(ABS(LITV(.X)));
PCIVR(.X,0);
REGSEARCH(X,0);
CODE(MOVM,REG_ACQUIRE(-1,1),MEMORYA(.X),1);
LEXRA(.REG)
END;
ROUTINE GSGN(X)=
!GENERATE CODE FOR SIGN(X)
BEGIN LOCAL REG,ADDR;
IF LITP(.X) THEN RETURN LITLEXEME(SIGN(LITV(.X)));
PCIVR(.X,0);
CODE(SKIPE,REG_ACQUIRE(-1,1),ADDR_MEMORYA(.X),0);
CODE(SETO,.REG,0,0);
CODE(SKIPLE,0,.ADDR,0);
CODE(MOVEI,.REG,1,0);
LEXRA(.REG)
END;
EXTERNAL GOFFSET;
CASE .TYPE OF SET
GJFFO(.PARAMETER);
GMOVM(.PARAMETER);
%2.10% GSGN(.PARAMETER);
%2.10% GOFFSET(.PARAMETER)
TES
END;
GLOBAL ROUTINE GSPLF(T,P1,P2)=
! GENERATE CODE FOR SP-FCNS:
! 1 --> SCANN
! 2 --> SCANI
! 3 --> REPLACEN
! 4 --> REPLACEI
! 5 --> COPYNN
! 6 --> COPYNI
! 7 --> COPYIN
! 8 --> COPYII
! 9 --> INCP
! 10--> ASH %5-17-77%
! 11--> ROT %5-17-77%
! 12--> LSH %5-17-77%
IF .T GEQ 10
THEN
BEGIN
EXTERNAL GASH,GROT,GLSH;
CASE .T - 10 OF
SET
GASH(.P1,.P2);
GROT(.P1,.P2);
GLSH(.P1,.P2)
TES
END
ELSE
BEGIN LOCAL R;
PCIVR(.P1,.P2);
P1_IF .P1<COPF> THEN GAT(.P1) ELSE GDOT(.P1);
IF .T GEQ 5 THEN (P2_IF .P2<COPF> THEN GAT(.P2) ELSE GDOT(.P2));
IF (T_.T-1) LEQ 1 THEN
BEGIN !SCANN AND SCANI
CODE(LDB-.T,R_ACQUIRE(-1,1),GMA(.P1),1);
SESTOG_.SESTOG OR 1
END ELSE
IF .T LEQ 3 THEN
!REPLACEN AND REPLACEI
%3.25% CODE(DPB-(.T-2),R_REGAK(GLAR(.P2)),GMA(.P1),5) ELSE
IF .T EQL 8 THEN
!INCP
CODE(IBP,R_0,GMA(.P1),5)
ELSE
!COPYNN, COPYNI, COPYIN, COPYII
BEGIN
CODE(LDB-(.T GTR 5),R_ACQUIRE(-1,1),GMA(.P1),1);
CODE(DPB-(.T AND 1),REGAK(LEXRA(.R)),GMA(.P2),5)
END;
SESTOG_.SESTOG OR 8;
IF .R NEQ 0 THEN LEXRA(.R) ELSE ZERO
END;
GLOBAL ROUTINE GML(F,A,M,X,I)=
! GENERATE CODE FOR MACHINE LANGUAGE CONSTRUCT. A IS GUARANTEED TO
! BE A LITERAL. NOTE THAT I MUST ALSO BE A LITERAL OTHERWISE AN
! ERROR IS GIVEN
BEGIN LOCAL VA,INDIRMASK;
VA_LITV(.A) AND 1^4-1;
IF LITP(.I) THEN (INDIRMASK_(LITV(.I) AND 1)^22; I_0)
ELSE RETURN ERROR(.NDEL,#147);
M_GPTR(.M,0,36,.X,.I);
IF NOT REGP(.M) THEN M_GDOT(.M);
CODE(.F,REGAK(A_LEXRA(.VA)),MEMORYA(.M) OR .INDIRMASK,.ART[.VA]<DTF>);
IF .F LEQ #130 THEN SESTOG_.SESTOG OR 8;
.A
END;
%3.1% GLOBAL ROUTINE CONVEY(X)=
% GENERATE CODE TO MOVE X TO .VREG, THE VALUE-REGISTER. %
GESCAPE(.X,CNVEYC);
GLOBAL ROUTINE GRETURN(X)=
% GENERATE CODE FOR RETURN X. %
BEGIN
LOCAL V,C,I; REGISTER PTRTOI;
PCIVR(.X,0);
V_GESCAPE(.X,CODEC);
I_.CODEPTR; PTRTOI_I;
DO C_.CT[ADVR1(.PTRTOI),0]<CLASSF> UNTIL
IF .C GEQ BEC THEN
CASE .C-BEC OF
SET
%BEC%
BEGIN
CODE(XCT,0,LABLE(ADVR1(.PTRTOI)),0);
SURFACE(.PTRTOI)
END;
%FRC%
GUJUMP(ADVR1(.PTRTOI));
%CURRENTC%
0
TES ELSE
IF .I EQL .PROGRAM THEN RETURN ERROR(.NDEL,#144) ELSE
SURFACE(.PTRTOI);
.V
END;
! OVERALL COMMENT ON HOW EXIT STATEMENTS ARE HANDLED:
!
! TO INSURE THAT CODE TO CONVEY UNUSED VALUES IS DISCARDED WHEN AN
! EXIT STATEMENT IS GENERATED, THE CONVEYING CODE IS HUNG OFF A HEADER OF
! TYPE XLOOPC, XCASEC, ETC. DEPENDING ON THE CONTROL ENVIRONMENT BEING
! EXITED. FOR EXAMPLE, THE EXIT STATEMENT:
! DO DO IF .A THEN .B ELSE EXIT[2] WHILE C() UNTIL D()
! IS GENERATED INTERNALLY BY GXEXIT AS THOUGH IT WAS AN EXITLOOP[1]. THE
! SUBCLASS FIELD OF THE EXITC HEADER CONTAINS THE COUNT OF THE NUMBER OF
! LEVELS OF CONTROL OF THIS CLASS TO BE EXITED. EACH TIME THE PROMOTE
! ROUTINE (SEE LOLSTPKG) IS CALLED BY THE APPROPRIATE CONTROL ROUTINE OF
! THIS CLASS IT DECREMENTS THIS COUNT BY 1. WHEN THE COUNT REACHES 0, THEN
! THE EXITCLASS IS CHANGED TO A CONVEYC AND THE VALUE IS SUBSEQUENTLY
! RETAINED OR DISCARDED.
%V2H% GLOBAL ROUTINE GLEAVE(X,N)=
%V2H% !THIS ROUTINE WILL EVENTUALLY REPLACE GXEXIT AND THE
%V2H% !INDIVIDUAL EXIT CONTROL ROUTINES EXCEPT FOR PERHAPS
%V2H% !EXITLOOP FOR BLIS11 COMPATIBILITY. THIS REPLACES
%V2H% !ALL "EXIT" TYPE EXCAPES WITH "LEAVE" TYPE ESCAPES. IT
%V2H% !IS BASICALLY PATTERNED AFTER GXEXIT AND USES PRETTY MUCH THE
%V2H% !THE SAME MECHANISM.
%V2H% ! GENERATE JUMP TO PROPER LABEL. SEE COMMENT ABOVE.
%V2H%
%V2H% BEGIN
%V2H% STRUCTURE EXITVECT[I]=[I](.EXITVECT-2+.I)<0,36>;
%V2H%
%V2H% BIND XCLASSES=1^COSTC+1^SELECTC+1^CMPEXC+1^ITEC+1^DWUC+1^WUDC+1^IDFTDC+1^BEC;
%V2H% REGISTER C, ! CLASS OF CELL BEING TESTED
%V2H% SUBCLASS, ! SUBCLASS OF CELL BEING TESTED
%V2H% EXTYPE, ! TYPE(CLASS) OF CONTROL ACTUALLY EXITED
%V2H% CODEPTRSAV, ! A TEMP TO HOLD CODEPTR (NEC. BECAUSE LOCATE STARTS SEARCH AT .CODEPTR)
%V2H% PTRTOI; ! HOLDS POINTER TO I TO PASS TO ADVR1, ETC.
%V2H%
%V2H% LOCAL V, ! LEXEME OF VALUE REGISTER
%V2H% EXCODIND, ! INDEX OF HEADER W/ CODE TO LOAD VREG
%V2H% I, ! INDEX OF CELL BEING TESTED
%V2H% CODEPROD, ! BOOLEAN INDICATING CODE GENERATED TO LOAD VREG
%V2H% EXITVECT NUM[6],! A VECTOR IN WHICH NUM[I] CONTAINS THE
%V2H% ! NUMBER OF LEVELS OF EXITABLE CONTROL
%V2H% ! OF TYPE I ACTUALLY EXITED
%V2H% ICURR, !TO SAVE CURRENT CONTENTS OF I
%V2H% HEADER; !INDEX OF HEADER OF WHICH .I IS CURRENTLY A SUBHEADER.
%V2H%
%V2H% PCIVR(.X,0);
%V2H% CODEPROP_0;
%V2H% V_GESCAPE(.X,XITC);
%V2H% CODEPROD_.CODEPROP;
%V2H% I_.CODEPTR;
%V2H% PTRTOI_I;
%V2H% EXCODIND_.CT[.CODEPTR,0]<PREVF>;
%V2H% NUM[2]_NUM[3]_NUM[4]_NUM[5]_NUM[6]_NUM[7]_0;
%V2H% DO C_.CT[ADVR1(.PTRTOI),0]<CLASSF> UNTIL
%V2H% IF (1^.C AND XCLASSES) NEQ 0 OR (.C GEQ BEC) THEN
%V2H% BEGIN
%V2H% SUBCLASS_.CT[.I,1]<CLASSF>;
%V2H% ICURR_.I; !SAVE CURRENT INDEX
%V2H% SURFACE(.PTRTOI); !GET HEADER INDEX
%V2H% HEADER_.I; !SAVE HEADER INDEX
%V2H% I_.ICURR; !RESTORE OLD I
%V2H% CASE .C - COSTC OF
%V2H% SET
%V2H% !COSTC ******** #16
%V2H% BEGIN
%V2H% NUM[XCOSTC]_.NUM[XCOSTC]+1;
%V2H% IF .N EQL .HEADER
%V2H% THEN
%V2H% BEGIN
%V2H% EXTYPE_XCOSTC;
%V2H% CODEPTRSAV_.CODEPTR; CODEPTR_.I;
%V2H% I_LOCATE(COSTC,7);
%V2H% CODEPTR_.CODEPTRSAV;
%V2H% GUJUMP(.I)
%V2H% END
%V2H% ELSE SURFACE(.PTRTOI)
%V2H% END;
%V2H% !SELECTC ******** #17
%V2H% BEGIN
%V2H% NUM[XSELECTC]_.NUM[XSELECTC]+1;
%V2H% IF .N EQL .HEADER THEN
%V2H% BEGIN
%V2H% EXTYPE_XSELECTC;
%V2H% CODEPTRSAV_.CODEPTR; CODEPTR_.I;
%V2H% I_LOCATE(SELECTC,5);
%V2H% CODEPTR_.CODEPTRSAV;
%V2H% GUJUMP(.I)
%V2H% END
%V2H% ELSE SURFACE(.PTRTOI)
%V2H% END;
%V2H% 0; !SELELC ******** #20
%V2H% 0; !EXCHC ******** #21
%V2H% 0; !CREATC ******** #22
%V2H% 0; !UNUSED ******** #23
%V2H% 0; !UNUSED ******** #24
%V2H% 0; !CASEC ******** #25
%V2H% 0; !SETC ******** #26
%V2H% 0; !NSETC ******** #27
%V2H% !CMPEXC ******** #30
%V2H% BEGIN
%V2H% NUM[XCMPEXC]_.NUM[XCMPEXC]+1;
%V2H% IF .N EQL .HEADER THEN
%V2H% (EXTYPE_XCMPEXC;GUJUMP(ADVR1(.PTRTOI));CT[.CT[.I,0]<NEXTF>,2]_1)
%V2H% ELSE SURFACE(.PTRTOI)
%V2H% END;
%V2H% !ITEC ******** #31
%V2H% BEGIN
%V2H% NUM[XCONDC]_.NUM[XCONDC]+1;
%V2H% IF .N EQL .HEADER
%V2H% THEN
%V2H% BEGIN
%V2H% EXTYPE_XCONDC;
%V2H% CODEPTRSAV_.CODEPTR; CODEPTR_.I;
%V2H% I_LOCATE(ITEC,5);
%V2H% CODEPTR_.CODEPTRSAV;
%V2H% GUJUMP(.I)
%V2H% END
%V2H% ELSE SURFACE(.PTRTOI)
%V2H% END;
%V2H% !DWUC ******** #32
%V2H% BEGIN
%V2H% NUM[XLOOPC]_.NUM[XLOOPC]+1;
%V2H% IF .N EQL .HEADER
%V2H% THEN
%V2H% BEGIN
%V2H% EXTYPE_XLOOPC;
%V2H% CODEPTRSAV_.CODEPTR; CODEPTR_.I;
%V2H% I_LOCATE(DWUC,4);
%V2H% CODEPTR_.CODEPTRSAV;
%V2H% GUJUMP(.I)
%V2H% END
%V2H% ELSE SURFACE(.PTRTOI)
%V2H% END;
%V2H% !WUDC ******** #33
%V2H% BEGIN
%V2H% NUM[XLOOPC]_.NUM[XLOOPC]+1;
%V2H% IF .N EQL .HEADER
%V2H% THEN
%V2H% BEGIN
%V2H% EXTYPE_XLOOPC;
%V2H% CODEPTRSAV_.CODEPTR; CODEPTR_.I;
%V2H% I_LOCATE(WUDC,6);
%V2H% CODEPTR_.CODEPTRSAV;
%V2H% GUJUMP(.I)
%V2H% END
%V2H% ELSE SURFACE(.PTRTOI)
%V2H% END;
%V2H% !IDFTDC ******** #34
%V2H% BEGIN
%V2H% NUM[XLOOPC]_.NUM[XLOOPC]+1;
%V2H% IF .N EQL .HEADER THEN
%V2H% BEGIN
%V2H% EXTYPE_XLOOPC;
%V2H% CODEPTRSAV_.CODEPTR; CODEPTR_.I;
%V2H% I_LOCATE(IDFTDC,6);
%V2H% CODEPTR_.CODEPTRSAV;
%V2H% GUJUMP(.I)
%V2H% END
%V2H% ELSE SURFACE (.PTRTOI)
%V2H% END;
%V2H% !BEC ******** #35
%V2H% BEGIN
%V2H% NUM[XBLOCKC]_.NUM[XBLOCKC]+1;
%V2H% IF .N EQL .HEADER THEN (EXTYPE_XBLOCKC;GUJUMP(ADVR1(.PTRTOI)); CT[ADVR2(.PTRTOI),2]_1)
%V2H% ELSE (CODE(XCT,0,LABLE(ADVR1(.PTRTOI)),0);SURFACE(.PTRTOI))
%V2H% END;
%V2H% !FRC ******** #36
%V2H% RETURN(ERROR(.NDEL,#144));
%V2H% !CURRENTC ******** #37
%V2H% 0
%V2H% TES
%V2H% END ELSE
%V2H% IF .I EQL .PROGRAM THEN RETURN ERROR(.NDEL,#144)
%V2H% ELSE SURFACE (.PTRTOI);
%V2H% IF .CODEPROD NEQ 0 THEN
%V2H% BEGIN
%V2H% CT[.EXCODIND,0]<CLASSF>_.EXTYPE;
%V2H% CT[.EXCODIND,1]<HDRCLASSF>_.NUM[.EXTYPE]
%V2H% END;
%V2H% .V
%V2H% END;
ROUTINE GXEXIT(X,N,XTYPE,XCLASSES)=
! CALLED BY ALL THE EXIT ROUTINES TO GENERATE CODE TO CONVEY VALUE
! GENERATE JUMP TO PROPER LABEL. SEE COMMENT ABOVE.
BEGIN
STRUCTURE EXITVECT[I]=[I](.EXITVECT-2+.I)<0,36>;
REGISTER C, ! CLASS OF CELL BEING TESTED
SUBCLASS, ! SUBCLASS OF CELL BEING TESTED
EXTYPE, ! TYPE(CLASS) OF CONTROL ACTUALLY EXITED
CODEPTRSAV, ! A TEMP TO HOLD CODEPTR (NEC. BECAUSE LOCATE STARTS SEARCH AT .CODEPTR)
PTRTOI; ! HOLDS POINTER TO I TO PASS TO ADVR1, ETC.
LOCAL V, ! LEXEME OF VALUE REGISTER
EXCODIND, ! INDEX OF HEADER W/ CODE TO LOAD VREG
I, ! INDEX OF CELL BEING TESTED
CODEPROD, ! BOOLEAN INDICATING CODE GENERATED TO LOAD VREG
EXITVECT NUM[6];! A VECTOR IN WHICH NUM[I] CONTAINS THE
! NUMBER OF LEVELS OF EXITABLE CONTROL
! OF TYPE I ACTUALLY EXITED
PCIVR(.X,0);
CODEPROP_0;
V_GESCAPE(.X,.XTYPE);
CODEPROD_.CODEPROP;
I_.CODEPTR;
PTRTOI_I;
EXCODIND_.CT[.CODEPTR,0]<PREVF>;
NUM[2]_NUM[3]_NUM[4]_NUM[5]_NUM[6]_NUM[7]_0;
DO C_.CT[ADVR1(.PTRTOI),0]<CLASSF> UNTIL
IF (1^.C AND .XCLASSES) NEQ 0 OR (.C GEQ BEC) THEN
BEGIN
SUBCLASS_.CT[.I,1]<CLASSF>;
CASE .C - SETC OF
SET
!SETC
BEGIN
N_.N-1;NUM[XCOSTC]_.NUM[XCOSTC]+1;
IF .N EQL 0 THEN
BEGIN
CODEPTRSAV_.CODEPTR; CODEPTR_.I;
I_IF .CT[LOCATE(COSTC,0),3] AND
((1^CASEC AND .XCLASSES) EQL 0) THEN
LOCATE(SETC,3)
ELSE LOCATE(COSTC,7);
CODEPTR_.CODEPTRSAV;
EXTYPE_XCOSTC;
GUJUMP(.I)
END
ELSE SURFACE(.PTRTOI)
END;
!NSETC
BEGIN
N_.N-1;NUM[XSELECTC]_.NUM[XSELECTC]+1;
IF .N EQL 0 THEN
BEGIN
EXTYPE_XSELECTC;
CODEPTRSAV_.CODEPTR; CODEPTR_.I;
I_LOCATE(SELECTC,5);
CODEPTR_.CODEPTRSAV;
GUJUMP(.I)
END
ELSE SURFACE(.PTRTOI)
END;
!CMPEXC
BEGIN
N_.N-1;NUM[XCMPEXC]_.NUM[XCMPEXC]+1;
IF .N EQL 0 THEN
(EXTYPE_XCMPEXC;GUJUMP(ADVR1(.PTRTOI));CT[.CT[.I,0]<NEXTF>,2]_1)
ELSE SURFACE(.PTRTOI)
END;
!ITEC
IF .SUBCLASS EQL 1 THEN SURFACE(.PTRTOI)
ELSE
BEGIN
N_.N-1;NUM[XCONDC]_.NUM[XCONDC]+1;
IF .N EQL 0 THEN
(EXTYPE_XCONDC;GUJUMP(IF .SUBCLASS EQL 2 THEN ADVR3(.PTRTOI) ELSE ADVR1(.PTRTOI)))
ELSE SURFACE(.PTRTOI)
END;
!DWUC
IF .SUBCLASS NEQ 2 THEN SURFACE(.PTRTOI)
ELSE
BEGIN
N_.N-1;NUM[XLOOPC]_.NUM[XLOOPC]+1;
IF .N EQL 0 THEN (EXTYPE_XLOOPC;GUJUMP(ADVR2(.PTRTOI)))
ELSE SURFACE(.PTRTOI)
END;
!WUDC
IF .SUBCLASS NEQ 3 THEN SURFACE (.PTRTOI)
ELSE
BEGIN
N_.N-1;NUM[XLOOPC]_.NUM[XLOOPC]+1;
IF .N EQL 0 THEN (EXTYPE_XLOOPC;GUJUMP(ADVR3(.PTRTOI)))
ELSE SURFACE(.PTRTOI)
END;
!IDFTDC
IF .SUBCLASS NEQ 3 THEN SURFACE(.PTRTOI)
ELSE
BEGIN
N_.N-1;NUM[XLOOPC]_.NUM[XLOOPC]+1;
IF .N EQL 0 THEN
BEGIN
EXTYPE_XLOOPC;
CODEPTRSAV_.CODEPTR; CODEPTR_.I;
I_LOCATE(IDFTDC,6);
CODEPTR_.CODEPTRSAV;
GUJUMP(.I)
END
ELSE SURFACE (.PTRTOI)
END;
!BEC
BEGIN
IF (1^BEC AND .XCLASSES) NEQ 0 THEN
(N_.N-1;NUM[XBLOCKC]_.NUM[XBLOCKC]+1);
IF .N EQL 0 THEN (EXTYPE_XBLOCKC;GUJUMP(ADVR1(.PTRTOI)); CT[ADVR2(.PTRTOI),2]_1)
ELSE (CODE(XCT,0,LABLE(ADVR1(.PTRTOI)),0);SURFACE(.PTRTOI))
END;
!FRC
RETURN(ERROR(.NDEL,#144));
!CURRENTC
0
TES
END ELSE
IF .I EQL .PROGRAM THEN RETURN ERROR(.NDEL,#144)
ELSE SURFACE (.PTRTOI);
IF .CODEPROD NEQ 0 THEN
BEGIN
CT[.EXCODIND,0]<CLASSF>_.EXTYPE;
CT[.EXCODIND,1]<HDRCLASSF>_.NUM[.EXTYPE]
END;
.V
END;
GLOBAL ROUTINE GXBLOCK(X,N)=GXEXIT(.X,.N,XBLOCKC,1^BEC);
GLOBAL ROUTINE GXLOOP(X,N)=GXEXIT(.X,.N,XLOOPC,1^DWUC OR 1^WUDC OR 1^IDFTDC);
GLOBAL ROUTINE GXCOND(X,N)=GXEXIT(.X,.N,XCONDC,1^ITEC);
GLOBAL ROUTINE GXCMPEX(X,N)=GXEXIT(.X,.N,XCMPEXC,1^CMPEXC);
GLOBAL ROUTINE GXSELECT(X,N)=GXEXIT(.X,.N,XSELECTC,1^NSETC);
GLOBAL ROUTINE GXSET(X,N)=GXEXIT(.X,.N,XCOSTC,1^SETC);
GLOBAL ROUTINE GXCASE(X,N)=GXEXIT(.X,.N,XCOSTC,1^CASEC OR 1^SETC);
GLOBAL ROUTINE GEXIT(X,N)=GXEXIT(.X,.N,XITC,1^SETC OR 1^NSETC OR
1^CMPEXC OR 1^ITEC OR 1^DWUC OR 1^WUDC
OR 1^IDFTDC OR 1^BEC);
ROUTINE GESCAPE(X,N)=
% CALLED FOR CONVEY AND ALL EXIT STATEMENTS. GENERATES CODE TO LOAD
VREG WITH X (IF NECESSARY). %
BEGIN
LOCAL V, ! LEXEME OF VALUE REGISTER
NAME; !RT-INDEX OF VREG'S NAME
IF LEXRN(.ART[.VREG]<RTEF>) EQL .X THEN RETURN .X;
NAME_.ART[.VREG]<RTEF>;
V_
IF .NAME NEQ 0 THEN
IF .X<RTEF> EQL .NAME THEN
INCRUSEN(.NAME)
ELSE
IF .NAME GEQ 16 THEN LEXRN(.NAME)
ELSE LEXRN(GETRN(.VREG,0,0))
ELSE LEXRN(GETRN(.VREG,0,0));
FOLLCPH(0,.N,0);
GLPR(.X,.VREG);
FOLLCPH(0,CODEC,0);
CLEARONE(RT[.V<RTEF>]);
.V
END;
ROUTINE GCUJUMP(X,J,N,U)=
% GENERATE CODE TO JUMP TO CODE TABLE ENTRY J,
CONDITIONALLY ON LEXEME X EQV N. FOR THE SPECIAL
CASE X EQV N AT COMPILE TIME, GENERATE AN
UNCONDITIONAL JUMP ONLY IF U=1, OTHERWISE GENERATE
NO CODE. %
! RETURNS:
! 0 --> X NOT EQV AT COMPILE TIME
! 1 --> X EQV N AT COMPILE TIME
! 2 --> EQUIVALENCE NOT KNOWN AT COMPILE TIME
!
! THIS IS THE ROUTINE THAT OPTIMIZES THE RELATIONAL BOOLEANS. E.G.:
! "IF .A LSS 0 THEN ..." ETC. GLSS (H2ARITH) HAS HUNG THE CODE FOR
! ".A LSS 0" OFF A RELC HEADER AND THIS ROUTINE MANIPULATES THAT CODE
! DISCARDING SOME OF IT. IT ALSO ATTEMPTS TO PRODUCE AOJLE ETC. FOR
! CONSTRUCTS OF THE FORM ... (A_.A+1) LEQ 0 ...
BEGIN
IF LITP(.X) THEN
RETURN
IF LITV(.X) EQV .N THEN
IF .U THEN GUJUMP(.J)
ELSE 1
ELSE 0;
IF NO(.X) THEN RETURN GCUJUMP(GYES(.X),.J,.N XOR 1,.U);
IF SIGN(.X) THEN RETURN GCUJUMP(GABS(.X),.J,.N,.U);
IF REGP(.X) AND (NULL(.CODEPTR) OR ALLNOS(.CODEPTR)) THEN
BEGIN
LOCAL AOJTYPE,CAI0TYPE,RELINST,INEQ,AOIND,FUNC;
MACRO AOINST=CT[.AOIND,1]$;
REGISTER HEADIND, ! INDEX OF RELC HEADER
PCH; ! INDEX OF CODE LIST PREVIOUS TO RELC
HEADIND_.CT[.CODEPTR,0]<PREVF>;
IF NOT .CT[.HEADIND,0]<CLASSF> EQL RELC THEN EXITBLOCK;
IF NOT .CT[.HEADIND,2] EQL .X THEN EXITBLOCK;
IF .CT[.CT[.HEADIND,1]<NEXTF>,1]<FUNCF> EQL MOVEI THEN ERASETOP(.HEADIND);
ERASEBOT(.HEADIND);
AOJTYPE_0;
CAI0TYPE_(.CT[.HEADIND,3] AND NOT (7^27 OR #17^23)) EQL CAI^27
AND .CT[RELINST_.CT[.HEADIND,1]<NEXTF>,0]<RELOCF> EQL 0;
INEQ_.CT[.HEADIND,3]<27,3>;
IF .CAI0TYPE THEN
BEGIN
PCH_.CT[.HEADIND,0]<PREVF>;
IF .CT[.PCH,0]<CLASSF> NEQ CODEC THEN EXITCOMP;
IF NULL(.PCH) OR ALLNOS(.PCH) THEN EXITCOMP;
AOIND_PREVCODE(.CT[.PCH,1]<PREVF>,.PCH);
AOINST_.CT[.AOIND,1];
FUNC_.AOINST<FUNCF>;
IF .AOINST<ACCF> NEQ .CT[.HEADIND,3]<ACCF> THEN EXITCOMP;
AOJTYPE_ .FUNC EQL AOJ OR .FUNC EQL SOJ;
IF .FUNC EQL AOS OR
.FUNC EQL SOS OR
.AOJTYPE THEN
BEGIN
EMPTY(.HEADIND);
RELINST_PUSHBOT(.HEADIND,TAKE(.AOIND));
CT[.HEADIND,3]_.AOINST;
CT[.HEADIND,3]<27,3>_CT[.RELINST,1]<27,3>_.INEQ;
CAI0TYPE_0
END
END;
FUNC_.CT[.HEADIND,3]<FUNCF>;
IF .CAI0TYPE OR .AOJTYPE THEN
BEGIN
FUNC_IF .AOJTYPE THEN .FUNC AND #770 ELSE JUMP;
CODE(.FUNC OR (.N^2 XOR .INEQ XOR 4),
.CT[.HEADIND,3]<ACCF>,LABLE(.J),0)
END
ELSE
BEGIN
CT[.RELINST,1]<27,3>_.INEQ XOR .N^2;
PUSHBOT(.CODEPTR,TAKE(.RELINST));
GUJUMP(.J)
END;
IF .FREEVHEADER LSS 0 THEN
BEGIN
EMPTY(.HEADIND);
CT[.HEADIND,0]<CLASSF>_CODEC;
CT[.HEADIND,1]<HDRCLASSF>_0;
RELEASESPACE(.HEADIND+2,1);
FREEVHEADER_.HEADIND
END
ELSE ERASE(.HEADIND);
DULEX(.X);
CLEARONE(RT[.X<RTEF>]);
RETURN 2
END;
BEGIN LOCAL P,S;
IF .FREEVHEADER LSS 0 THEN
BEGIN
FREEVHEADER_FOLLCPH(0,CODEC,0);
FOLLCPH(0,CODEC,0)
END;
IF .X<COPF> NEQ 0 AND (S_.X<SIZEF>) NEQ 0 AND
(P_.X<POSNF>) LSS 36 THEN
CODE(CASE .P/18*2+.N OF SET TRNN; TRNE; TLNN; TLNE TES,
RAGLAR(GAT(.X AND (RTEM OR LSSTEM))),
1^(.P MOD 18),0)
ELSE CODE(IF .N THEN TRNE ELSE TRNN,REGAR(GLAR(.X)),1,0);
GUJUMP(.J);
END;
2
END;
ROUTINE GUJUMP(J)=
% GENERATE UNCONDITIONAL JUMP TO J. %
BEGIN
CODE(JRST,0,LABLE(.J),0);
1
END;
ROUTINE LABLE(J)=
% SET RELOCATION FIELD OF J TO BE LABEL. %
BEGIN
J<RELOCF>_CTRELOC;
.J
END;
%%
%
THIS SUB-MODULE GENERATES THE LINKAGE CODE FOR
TIMING BLISS ROUTINES.
TIMSTE CONTAINS THE INDEX OF THE STE OF THE
TIMER ROUTINE NAME
%
%%
ROUTINE TIMLINK(MPINST,INST)=
BEGIN MACRO MAKEOP(OP,REG,ADDR)=((OP)<0,0>^27 + (REG)<0,0>^23 + (ADDR)<0,0>)$;
LOCAL REG;
CODE(.INST,.JSPREG,0,0);
IF .MPINST NEQ 0 THEN CODE(.MPINST,.JSPREG,#400000,0);
CODE (PUSH, .SREG,.JSPREG, 0);
CODE (PUSHJ,.SREG, GMA(.TIMSTE OR LSM OR DOTM), 0);
CODE (SUB, .SREG, LITA(LITLEXEME(1^18+1)), 0);
IF .DEBFLG THEN !PUT PUSHJ TO TIMER ROUTINE IN USERS .JB41
(WRITE9(#41,MAKEOP(PUSHJ,.SREG,0)); ! CODE
WRIT10(#41,GETNAM(TABLE[.TIMSTE + 2],6))); ! EXTERNAL REQUEST
%%
%
.INST R,0
PUSH $S,R
PUSHJ $S,<ROUTINE>
SUB $S,[1000001]
%
%%
END;
GLOBAL ROUTINE TIMEIN=TIMLINK(0,HRRZI);
GLOBAL ROUTINE TIMEOUT=BEGIN
CODE(PUSH,.SREG,.VREG,0);
TIMLINK(0,HRROI);
CODE(POP,.SREG,.VREG,0);
END;
GLOBAL ROUTINE MPTIMIN=TIMLINK(TLO,HRRZI);
GLOBAL ROUTINE MPTIMOUT=TIMLINK(TLZ,HRROI);
GLOBAL ROUTINE DEBIN(RTNSTE)=CODE(DEBUGUUO,0,GMA(.RTNSTE OR LSM OR DOTM),0);
GLOBAL ROUTINE DEBOUT(RTNSTE)=CODE(DEBUGUUO,1,GMA(.RTNSTE OR LSM OR DOTM),0);
!END OF H1CNTR.BLI