Directory of image this file is from
This file as a plain text file

	TITLE	SUPVSR - PPL SUPERVISOR        /TAS/EAT/ 20-SEP-72

	HISEG
	SEARCH	PPL



	SUBTTL	SUPERVISOR ENTRY AND INITIALIZATION

;CONVERSATION INITIALLY BEGINS IN THE "GLOBAL ENVIRONMENT", WHICH IS AN
;   ACTIVATION RECORD WITH NO CALLER, PROCID, FORMALS OR LOCALS.

;ENTER SUPERVISOR.
;	CONSTRUCT GLOBAL ACTIVATION RECORD.

SUPVSR:	CALL	SAVCLR		;UNPROTECT ANY SAVED PZ ADDRESSES
	CALL	MKBLK		;ALLOCATE BLOCK FOR ACTIVATION RECORD
	  BLKARG  SYSBIT+B.AR,ARBASE+ISTKL
	HRRZ	CAR,R		;CAR_PZADR OF CURRENT ACTIVATION RECORD
	MOVEM	CAR,RAF		;PLACE GLOBAL AR ALONE ON RING OF ACTIVE FNS
	HRRZ	B,(CAR)		;SETUP DZADR OF CAR
	SET	CAR,LRF		;SET LEFT AND RIGHT RING PTRS TO POINT TO SELF
	SET	CAR,RRF
	MOVEI	AC1,SUBATR	;GIVE GLOBAL AR THE ATTRIBUTES OF A SUBROUTINE
	SET	AC1,ATRF
	MOVE	TOP,[B,,ARBASE-1] ;INIT AR STACK PTR TO BOTTOM OF STACK

;STACK A SUSPEND CONTEXT WORD WITH A ZERO RH TO SIGNAL THE ABSENCE OF A
;   PREVIOUS CONTEXT (IN CASE THE USER TRIES TO RESUME OR GOTO IN THE
;   GLOBAL ENVIRONMENT)

	MOVSI	AC1,(LXM(CXTWD,SUSCWD))	;SETUP SUSPEND CONTEXT WORD
	CALL	STACK		;STACK IT (ALSO SET TOP INTO TOPF)
;HERE TO CONVERSE WITH THE USER UPON SUSPENSION OR ERROR.

GTLN:	MOVE	L,@TOP		;FETCH TOP LEXEME
	LGET	R,IACTF		;EXTRACT INTERPRETER ACTION FIELD
	CAIE	R,CXTWD		;ERROR IF NOT A CONTEXT WORD
	ERROR	MSG(CXTEX)	;CXTWD EXPECTED, NOT FOUND
	LGET	R,LTYPF		;FETCH CONTEXT TYPE
	MOVEI	AC1,%DEMAND	;ASSUME DEMAND INPUT
	CAIN	R,DMDCWD	;DEMAND CONTEXT WORD?
	JRST	GTLN1		;YES
	MOVEI	AC1,%TOP.PR	;NO, ASSUME SUSCWD.  SETUP TOP.PROMPT
	TRNE	L,-1		;ANY PREVIOUS CONTEXT?
	MOVEI	AC1,%SUSPEND	;YES, SETUP SUSPEND.PROMPT

;HERE TO STORE PROMPT IN CPRMPT AS CURRENT PROMPT

GTLN1:	CALL	INPINI		;SETUP PROMPT AND INPUT SOURCE
	MOVE	AC1,CAR		;SETUP ARG TO CONVER
	CALL	CONVER		;CONVERSE WITH USER, RETURN WITH
				;  R=PZADR OF TRANSLATED LINE
	SETZM	IFILE		;CLEAR INPUT FILE STATE
	SETZM	EVALBP
	HRRZ	B,(CAR)		;RESTORE DZADR OF CAR
	SET	R,LPF		;STORE PTR TO CURRENT LINE IN AR

;HERE TO INITIALIZE POSITION MARKER FIELD TO THE BEGINNING OF A LINE

SETPM2:	MOVEI	AC1,2		;FIRST LEXEME AT RELATIVE WORD 2 IN BLOCK
	SET	AC1,PMF		;STORE POSITION MARKER FIELD

;ENTER THE INTERPRETER.  IT IS ASSUMED ONLY THAT CAR CONTAINS THE PZADR OF
;   THE CURRENT AR, AND THAT ALL AR FIELDS HAVE BEEN PROPERLY INITIALIZED.

INTPGO:	JRST	INTERP		;ENTER INTERPRETER
	SUBTTL	HANDLE RETURNS FROM THE INTERPRETER

; ***** DEMAND EXIT *****
;RE-ENTER HERE FROM THE INTERPRETER UPON ENCOUNTERING A DEMAND SYMBOL.
;   L CONTAINS THE DEMAND SYMBOL LEXEME ENCOUNTERED.
;   HERE WE STACK A DEMAND CONTEXT WORD CONTAINING THE CURRENT LINE
;   POINTER AND POSITION MARKER, THEN GO BACK TO CONVERSE WITH THE USER.

DMND:	GET	AC1,LPF		;FETCH CURRENT LINE PTR FIELD
	HRLI	AC1,(LXM(CXTWD,DMDCWD)) ;CONSTRUCT DEMAND CONTEXT WORD
	STORE	(CPM,AC1,FCHNF)	;STORE CURRENT POSITION MARKER
	CALL	STACK		;STACK CONTEXT WORD
	TRNN	L,-1		;SKIP IF STRING DEMAND (?")
	JRST	GTLN		;GO GET ANOTHER LINE FROM THE USER
	MOVEI	AC1,%DEMAND	;STRING DEMAND, SETUP PROMPT
	CALL	INPINI		;STORE PROMPT AND SETUP INPUT SOURCE
	CALL	DMDSTR		;CONVERSE WITH USER; RETURN STRING
	SETZM	IFILE		;CLEAR INPUT FILE STATE
	HRRZ	B,(CAR)		;RESTORE DZADR OF CAR
	HRLI	R,(LXM(STAK,CONST)) ;SETUP CONST LEXEME FOR STRING
	MOVE	AC1,R		;AC1_LEXEME
	JRST	DMDCW1		;STORE RESULT ON STACK, POP CONTEXT

;ROUTINE TO STORE PROMPT AND PROPERLY SETUP IFILE FOR INPUT
;  CALL WITH AC1 = INTERNAL NAME OF PROMPT (ID)

INPINI:	HRLI	AC1,(LXM(STAK,ID)) ;TURN PROMPT INTO AN ID LEXEME
	MOVEM	AC1,CPRMPT	;STORE AS CURRENT PROMPT
	TLNN	FF,RDFLG	;READ SYSTEM FN IN PROGRESS?
	TDZA	AC1,AC1		;NO
	MOVEI	AC1,RWFCB	;YES, SETUP FCB FOR READING
	SKIPN	IFILE		;UNLESS ALREADY SETUP (INSTMT, INSTRING)
	MOVEM	AC1,IFILE	;  STORE INPUT FILE POINTER
	RETURN
;HERE FROM EXEC UPON ^C, REENTER WHILE IN TTY INPUT WAIT.
;   THE TOP LEXEME SHOULD BE A DEMAND OR SUSPENSION CONTEXT WORD.
;   IF IT IS A DEMAND CONTEXT WORD, WE RESTORE THE CONTEXT, THEN BACK
;   UP THE POSITION MARKER SO THAT THE "?" LEXEME WILL BE RE-EXECUTED
;   UPON RESUMPTION.

TTWSUS:	MOVE	P,[IOWD STKLEN,SYSSTK] ;RESET SYSTEM STACK
	CALL	KILLIO		;RESET FILE I/O IF ANY
	MOVE	CAR,SAVCAR	;RESTORE PZADR OF CURRENT ACTIVATION RECORD
	HRRZ	B,(CAR)		;SETUP DZADR OF CAR
	GET	TOP,TOPF	;FETCH TOP FIELD
	HRLI	TOP,B		;INDEX BY CAR DZADR
	MOVE	L,@TOP		;FETCH TOP LEXEME
	LGET	R,IACTF		;FETCH INTERPRETER ACTION FIELD
	CAIE	R,CXTWD		;IF NOT A CONTEXT WORD
	JRST	USRSUS		;  THEN MAY HAVE BEEN ARDS INPUT WAIT
	LGET	R,LTYPF		;FETCH LEXEME TYPE FIELD
	MOVSI	R2,(-1B<FCHNFP>) ;SETUP -1 IN FWD CHAIN FIELD
	CAIN	R,DMDCWD	;DID WE SUSPEND DURING "?" PROCESSING?
	ADDM	R2,@TOP		;YES, BACK UP POSITION MARKER ONE
	CALL	CXTRST		;RESTORE TOP CONTEXT
	SUBI	TOP,1		;POP CONTEXT WORD OFF STACK

; ***** USER SUSPENSION EXIT *****
;RETURN HERE UPON SUSPENSION BY THE USER VIA ^C, REENTER.  CPM SHOULD
;   BE SET SUCH THAT IT POINTS TO THE NEXT LEXEME TO BE INTERPRETED UPON
;   RESUMPTION.  WE STACK A SUSPENSION CONTEXT WORD CONTAINING THE
;   CURRENT LINE POINTER AND POSITION MARKER, THEN REQUEST INPUT FROM
;   THE USER.

USRSUS:	SETZB	FF,SUSPND	;CLEAR SYSTEM FLAGS AND SUSPENSION FLAG
	CALL	PNTSTP		;PRINT MSG SAYING WHERE WE STOPPED
	  TTOS	[SIXBIT/STOPPED IN DIRECT STMT#/]
	CALL	CXTSAV		;STACK SUSPENSION CONTEXT WORD
	JRST	GTLN		;GO CONVERSE WITH USER IN SUSPENDED ENVIRONMENT
; ***** ERROR EXIT *****
;COME HERE FROM THE INTERPRETER UPON DETECTING ANY EXECUTION ERROR.
;   IT IS ASSUMED ONLY THAT CAR CONTAINS THE PZADR OF THE CURRENT 
;   ACTIVATION RECORD.

;THE ERROR EXIT IS HANDLED BY THE FOLLOWING UUO'S:
;	EXERR	[SIXBIT/ERROR MESSAGE#/]
;	SFNERR	[SIXBIT/ERROR MESSAGE#/]
;   WHICH ARE IDENTICAL EXCEPT THAT SFNERR SHOULD BE CALLED ONLY WITHIN
;   THE EXECUTION OF SYSTEM FUNCTIONS, WHEN CFNAM CONTAINS THE NAME OF
;   THE FUNCTION BEING EXECUTED.
;OTHER UUOS ARE FOR PRINTING FILE ERROR MESSAGES.  THEY ARE IN THE FORM
;	DEVERR	AC,[SIXBIT/ERROR MESSAGE#/]
;	FILERR	AC,[SIXBIT/ERROR MESSAGE#/]
;   WHERE AC IS AN ACCUMULATOR CONTAINING THE ADDRESS OF THE ASSOCIATED
;   FILE CHANNEL BLOCK (FCB).  THE MESSAGES ARE RESPECTIVELY:
;	IN SYSTEM FN <FN-NAME>:  DEVICE <DEV> <MESSAGE>
;	IN SYSTEM FN <FN-NAME>:  FILE <DEV>:<FILENAME>.<EXT> <MESSAGE>
;   WHERE <DEV>, <FILENAME>, AND <EXT> ARE GOTTEN FROM THE FCB, AND
;   <FN-NAME> FROM CFNAM, EXCEPT THAT IF CFNAM IS ZERO, THE PREFIX IS
;   "EXECUTION ERROR".  THE CHANNEL IS THEN RELEASED AND THE FCB CLEARED.

;THE FOLLOWING UUO'S ARE SIMILAR TO THE ABOVE EXCEPT THAT THEY RETURN
;   TO THEIR CALLERS RATHER THAN CLEARING THE CONTROL STACK AND RESTARTING
;   THE SUPERVISOR:
;	SFNERP	[SAME AS SFNERR]
;	DEVERP	[SAME AS DEVERR]
;	FILERP	[SAME AS FILERR]

;AFTER PRINTING THE ERROR MESSAGE, WE RESET THE SYSTEM STACK, RESET THE
;   CURRENT POSITION MARKER FIELD TO THE BEGINNING OF THE CURRENT STATEMENT,
;   AND STACK A SUSPEND CONTEXT WORD IF ONE WAS NOT ALREADY THERE.  WE
;   THEN CONVERSE WITH THE USER.  IF THE USER RESUMES EXECUTION, THE
;   STATEMENT BEING EXECUTED AT THE TIME OF THE ERROR WILL BE STARTED OVER.

;EXERR, SFNERR ERROR HANDLERS

XEXERR:	SETZM	CFNAM		;EXERR - ENSURE NO FN NAME
XSFNER:	CALL	XSFNEP		;PRINT "IN SYSTEM FN XXX: "
;HERE FROM ERROR HANDLERS AFTER PRINTING MESSAGE.

RESTRT:	TLZE	FF,RSTFLG	;WAS RESTORE IN PROGRESS WHEN ERROR OCCURED?
	JRST	ENVLST		;YES, ENVIRONMENT IS LOST
	MOVE	P,[IOWD STKLEN,SYSSTK]  ;RESET SYSTEM STACK
	CALL	SAVCLR		;RESET PZ SAVE STACK
	HRRZ	B,(CAR)		;SETUP DZADR OF CURRENT AR
	MOVEI	CPM,2		;RESET CURRENT POSITION MKR TO START OF LINE
	SET	CPM,PMF
	GET	TOP,TOPF	;FETCH PTR TO TOP OF STACK
	HRLI	TOP,B		;INDEX BY AR DZADR
	CALL	CXTSRC		;SEARCH FOR TOPMOST CONTEXT WORD ON STACK
	MOVE	L,@TOP		;FETCH CONTEXT WORD
	LGET	R,LTYPF		;FETCH LEXEME TYPE FIELD
	CAIE	R,SUSCWD	;IS IT A SUSPENSION CONTEXT WORD?
	CALL	CXTSAV		;NO, STACK A SUSPENSION CONTEXT WORD
	CALL	PNTSTP		;PRINT MESSAGE SAYING WHERE WE STOPPED
	  JFCL			;DIRECT STATEMENT (SAY NOTHING)
	JRST	GTLN		;GO CONVERSE WITH USER IN ENV OF SUSPENSION

;HERE WHEN ERROR OCCURRED DURING RESTORE AND ENVIRONMENT IS PROBABLY
;   CLOBBERED.  SO RESTART PPL OVER

ENVLST:	TTOS	MSG(ENVLS)	;ENVIRONMENT LOST
	JRST	PPLRST

;SFNERP HANDLER

XSFNEP:	SAVE	<JOBUUO>	;SAVE ADR OF MESSAGE
	CALL	KILLIO		;STOP FILE I/O, ETC.
	CALL	PPRFIX		;PRINT FN NAME OR "EXECUTION ERROR"
	RESTOR	<JOBUUO>	;RESTORE ADR OF MESSAGE
	TTOS	@JOBUUO		;PRINT MESSAGE
	RETURN

;DEVERR, FILERR UUOS

UDVERR:	PUSHJ	P,UDVERP	;CALL DEVICE MESSAGE ROUTINE
	JRST	RESTRT		;GO STOP PROGRAM

UFLERR:	PUSHJ	P,UFLERP	;CALL FILE MESSAGE ROUTINE
	JRST	RESTRT		;GO STOP PROGRAM
;DEVERP, FILERP UUOS

UDVERP:	TRZA	FF,FILFLG	;REMEMBER DEVERR
UFLERP:	TRO	FF,FILFLG	;REMEMBER FILERR
	SAVE	<AC1,AC2,JOBUUO> ;SAVE AC'S CLOBBERED WITHIN
	MOVEM	AC2,TSAV	;SAVE AC2 AGAIN
	LDB	AC2,[POINT 4,JOBUUO,12] ;GET AC FIELD OF UUO
	EXCH	AC2,TSAV	;RESTORE AC AND PUT AC FIELD IN TSAV
	MOVE	AC2,@TSAV	;GET CONTENTS OF REFERENCED AC
	CALL	KILLIO		;TERMINATE READ/WRITE, ETC
	CALL	PPRFIX		;PRINT FN NAME OR "EX ERROR"
	JUMPE	AC2,MESTYP	;JUMP IF I/O WAS TO TTY
	TRNN	FF,FILFLG	;DEVICE OR FILE?
	TTOS	[SIXBIT/DEVICE !/]
	TRNE	FF,FILFLG
	TTOS	[SIXBIT/FILE !/]
	MOVE	AC1,FILDEV(AC2)	;GET DEVICE NAME
	CALL	W6WD		;PRINT IT
	TRNE	FF,FILFLG	;FILE?
	SKIPN	AC1,FILNAM(AC2)	;YES, NON-BLANK FILENAME?
	JRST	UFLERX		;NO TO EITHER
	TTOI	":"		;YES, COLON
	CALL	W6WD		;PRINT FILENAME
	TTOI	"."		;PERIOD
	HLLZ	AC1,FILEXT(AC2)	;PRINT EXTENSION
	CALL	W6WD
UFLERX:	TTOI	" "		;SPACE
MESTYP:	RESTOR	<AC1>		;GET BACK ADR OF MESSAGE
	TTOS	(AC1)		;PRINT MESSAGE
	MOVE	AC1,AC2		;AC1_ADR OF FCB
	CALL	RELCHN		;RELEASE THE CHANNEL
	JRST	X21		;RESTORE AC'S AND RETURN
;ROUTINE TO PRINT PREFIX OF ERROR MESSAGE AS:
;	EXECUTION ERROR:		(IF (CFNAM)=0)
;	IN SYSTEM FN XXX:		(IF (CFNAM)#0)

PPRFIX:	SKIPN	AC1,CFNAM	;GET AND TEST CFNAM
	JRST	NOFNAM		;NONE
	TTOS	[SIXBIT/IN SYSTEM FN !/]
	PUSHJ	P,IDPR		;PRINT FUNCTION NAME
	TTOS	[SIXBIT/:  !/]
	RETURN

NOFNAM:	TTOS	[SIXBIT/EXECUTION ERROR:  !/]
	RETURN

;ROUTINE TO PRINT SIXBIT STRING UP TO 6 CHARACTERS LONG, WITH TRAILING
;   BLANKS SUPPRESSED.  ENTER WITH STRING IN AC1.

W6WD:	MOVE	R2,AC1		;GET ARG
W6WD1:	SETZ	R,		;CLEAR ADJACENT AC
	LSHC	R,6		;SHIFT IN NEXT CHAR
	TTOI	40(R)		;PRINT IT
	JUMPN	R2,W6WD1	;BACK FOR MORE IF NONZERO
	RETURN
; ***** FUNCTION CALL EXIT *****
;WHEN WE GET HERE, THE CALLEE HAS ALREADY BEEN INITIALIZED AND PLACED
;   ON THE RING OF ACTIVE FUNCTIONS.  PARAMETERS HAVE BEEN PASSED.
;   WE NOW SUSPEND THE CURRENT (CALLEE) ACTIVATION RECORD AND BEGIN
;   EXECUTING THE CALLEE.

FNCALX:	MOVE	AC1,CAR		;LOAD PZADR OF CAR
	MOVEI	AC2,RAF		;LOAD ADR OF ACTIVE RING REFERENT
	CALL	DELETE		;REMOVE CALLER FROM RAF
	MOVEI	AC2,RSF		;LOAD ADR OF SUSPENDED RING REFERENT
	CALL	INSIRT		;INSERT CALLER INTO RSF
	MOVE	CAR,RAF		;CAR_PZADR OF NEXT AR TO SERVICE
	JRST	SAR		;GO SETUP POINTERS AND SERVICE IT


; ***** FOR STATEMENT EXIT *****
;THE AR STACK CONTAINS THE FOLLOWING OBJECTS:
;	I  S  U  T
;WHICH ARE OBTAINED FROM THE STATEMENT
;	FOR I_L:S:U DOTHRU T
;THE FOLLOWING OPERATIONS HAVE ALREADY BEEN PERFORMED:
;	L,S,U	COERCED TO CONSTANTS AND VERIFIED TO BE ARITHMETIC
;	T	DETERMINED TO BE AN INT, THEN STACKED AS A RELOC
;	I_L	ASSIGNMENT PERFORMED.

;AFTER VERIFYING THE LEGALITY OF THE STATEMENT, WE TRACE IF REQUIRED, THEN
;   STACK A FOR CONTEXT WORD CONTAINING THE CURRENT LINE NUMBER +1.
;   WE THEN JUMP TO THE RANGE CHECK CODE, WHICH DETERMINES WHETHER THE
;   STATEMENTS WITHIN THE SCOPE SHOULD BE EXECUTED AT ALL.

FORSTX:	GET	B,LPF		;FETCH PZADR OF CURRENT LINE
	HRRZ	B,(B)		;FETCH DZADR
	GET	R,NF		;FETCH LINE'S STATEMENT NUMBER FIELD
	HRRZ	B,(CAR)		;RESTORE DZADR OF CAR
	JUMPG	R,.+2		;ERROR IF IMMEDIATELY EXECUTED LINE
	EXERR	MSG(FORDR)	;FOR STATEMENT MAY NOT BE GIVEN DIRECTLY
	GET	AC1,LNF		;OK, GET CURRENT LINE NUMBER
	HRRE	R,@TOP		;FETCH TARGET LINE NUMBER
	CAML	AC1,R		;ERROR IF NULL OR NEGATIVE FOR SCOPE
	EXERR	MSG(NOFOR)	;NO STATEMENTS IN SCOPE OF "FOR"
	CALL	TRCIRQ		;OK, TRACE IF REQUIRED.
	HRLI	AC1,(LXM(CXTWD,FORCWD)) ;CONSTRUCT FOR CONTEXT WORD
	ADDI	AC1,1		;PUT CURRENT LINE NO. +1 IN RH
	CALL	STACK		;STACK CONTEXT WORD
	JRST	FRNGCK		;GO PERFORM RANGE CHECK
; ***** RIGHT PAD EXIT *****
;HERE UPON ENCOUNTERING A RIGHT PAD LEXEME IN THE INPUT STREAM.  SWITCH
;   ON THE TYPE OF THE CONTEXT WORD THAT SHOULD BE FOUND AT TOP-1.

RPADX:	SUBI	TOP,1		;POINT TO TOP-1 ON STACK
	MOVE	L,@TOP		;FETCH LEXEME AT THAT POSITION
	LGET	R,IACTF		;EXTRACT INTERPRETER ACTION FIELD
	CAIE	R,CXTWD		;SYSTEM ERROR IF NOT CONTEXT WORD
	ERROR	MSG(CXTEX)	;CXTWD EXPECTED, NOT FOUND
	LGET	R,LTYPF		;FETCH LEXEME TYPE FIELD
	HLRZ	R,CWTYPE(R)	;PICK UP LH DISPATCH ENTRY FOR CXTWD TYPE
	AOJA	TOP,(R)		;DISPATCH, RESTORING TOP POINTER

;CONTEXT WORD TYPE DISPATCH TABLE.
;   LH ENTRIES USED AT RPADX.  RH ENTRIES USED AT FRNGCK.

CWTYPE:	FORCWX	,, FSCPCK	;FOR CONTEXT WORD
	BOTCWX	,, ILN		;BOTTOM CONTEXT WORD
	DMDCWX	,, IMPCXT	;DEMAND CONTEXT WORD
	SUSCWX	,, IMPCXT	;SUSPEND CONTEXT WORD

;DEMAND CONTEXT WORD WAS ON STACK.  SUBSTITUTE THE VALUE OF THE STMT
;   JUST EXECUTED FOR THE CONTEXT WORD, THEN RESTORE THE PREVIOUS CONTEXT
;   AND RESUME EXECUTION.

DMDCWX:	MOVE	AC1,@TOP	;FETCH LEXEME FROM TOP OF STACK
	SUBI	TOP,1		;POINT TO CONTEXT WORD
	SET	TOP,TOPF	;RESET TOP FIELD OF CAR
DMDCW1:	CALL	CXTRST		;RESTORE LPF AND PMF FROM CONTEXT WORD AT TOP
	MOVEM	AC1,@TOP	;SUBSTITUTE VALUE OF DEMAND EXPR FOR CXTWD
	JRST	INTPGO		;RETURN TO INTERPRETER

;SUSPEND CONTEXT WORD WAS ON STACK.  PRINT (IF REQUIRED) THE VALUE NOW
;   RESIDING ON THE STACK, WHICH WAS THE RESULT OF EXECUTING AN IMMEDIATE
;   EXPRESSION SUBMITTED BY THE USER.  THEN RETURN TO THE USER FOR ANOTHER
;   LINE OF INPUT, THUS REMAINING IN THE SUSPENDED STATE.

SUSCWX:	CALL	PNTIRQ		;PRINT TOP EXPRESSION IF REQUIRED
	SUBI	TOP,1		;POP TOP LEXEME (CONTAINING VALUE)
	SET	TOP,TOPF	;STORE ADJUSTED TOP PTR
	JRST	GTLN		;GO CONVERSE WITH USER

;BOTTOM CONTEXT WORD WAS ON STACK.  PRINT AND/OR TRACE IF REQUIRED,
;   UNSTACK THE TOP LEXEME, AND SEQUENCE TO THE NEXT LINE.

BOTCWX:	CALL	PNTTRC		;PRINT AND/OR TRACE IF REQ'D, THEN UNSTACK
	JRST	ILN		;INCREMENT LINE NUMBER
;FOR CONTEXT WORD WAS ON STACK.  AFTER PRINTING AND/OR TRACING, CHECK TO
;   SEE WHETHER THE STATEMENT JUST EXECUTED WAS THE LAST STATEMENT OF
;   THE INNERMOST FOR STATEMENT SCOPE.  IF SO, INCREMENT AND TEST THE
;   CONTROLLED VARIABLE, POSSIBLY EXITING THE SCOPE OF THE FOR.  IF NOT,
;   WE PROCEED TO THE NEXT STATEMENT AS USUAL.

FORCWX:	CALL	PNTTRC		;PRINT AND/OR TRACE IF REQUIRED, AND UNSTACK

;HERE ON REPEATED SCOPE TESTS.  STACK CONTAINS  I  S  U  T  FORCWD

FSCPCK:	MOVEI	R,@TOP		;COMPUTE ABS ADR OF TOP OF STACK
	HRRZ	R,-1(R)		;FETCH LINE # OF END OF INNERMOST SCOPE
	GET	R2,LNF		;FETCH LINE # OF STMT JUST EXECUTED
	CAME	R,R2		;WAS IT LAST STATEMENT OF SCOPE?
	JRST	ILN		;NO, PROCEED TO EXECUTE NEXT LINE
	MOVE	ARGP,TOP	;YES, SETUP ARG PTR
	SUBI	ARGP,4		;POINT TO CONTROLLED VARIABLE ON STACK
	CALL	INCVAR		;INCREMENT CONTROLLED VARIABLE BY VALUE OF STEP

;PERFORM RANGE CHECK TO SEE WHETHER (U-L)*SIGN(S) >= 0.  IF SO, THE
;   RANGE HAS NOT BEEN EXCEEDED AND WE RETURN TO THE BEGINNING OF THE FOR SCOPE.
;   IF NOT, THE RANGE HAS BEEN EXCEEDED AND WE POP THE ENTIRE FOR CONTEXT
;   AND JUMP PAST THE END OF THE SCOPE.

FRNGCK:	MOVE	ARGP,TOP	;COPY PTR TO TOP OF STACK
	SUBI	ARGP,4		;POINT TO CONTROLLED VARIABLE
	CALL	RNGCHK		;PERFORM RANGE CHECK
	  JRST	  RPTFSC	;NOT OUT OF RANGE.  GO REPEAT FOR SCOPE
	SUBI	TOP,1		;OUT OF RANGE.  POP OFF FOR CONTEXT WORD
	HRRZ	R,@TOP		;FETCH TARGET LINE NUMBER
	SET	R,LNF		;SET LINE NUMBER FIELD IN AR
	SUBI	TOP,4		;POP OFF   I  S  U  T
	SET	TOP,TOPF	;STORE UPDATED TOP POINTER
	MOVE	L,@TOP		;FETCH TOP LEXEME NOW
	LGET	R,IACTF		;EXTRACT INTERPRETER ACTION FIELD
	CAIE	R,CXTWD		;SYSTEM ERROR IF NOT A CONTEXT WORD
	ERROR	MSG(CXTEX)	;CXTWD EXPECTED, NOT FOUND
	LGET	R,LTYPF		;FETCH LEXEME TYPE FIELD
	HRRZ	R,CWTYPE(R)	;FETCH DISPATCH ENTRY FOR CXTWD TYPE
	JRST	(R)		;DISPATCH

;ERROR FOR IMPROPER CONTEXT WORD TYPES

IMPCXT:	ERROR	MSG(IMPCX)	;IMPROPER CXTWD
;HERE TO INCREMENT CURRENT LINE NUMBER AND PROCEED TO THE NEXT LINE.

ILN:	GET	R,LNF		;FETCH CURRENT LINE NUMBER FIELD FROM AR
	AOJA	R,.+2		;INCREMENT

;HERE TO REPEAT A FOR SCOPE BY RESETTING THE CURRENT LINE NUMBER TO
;   THE FIRST STATEMENT IN THE SCOPE.

RPTFSC:	HRRZ	R,@TOP		;FETCH RH OF STACKED FORCWD
	SET	R,LNF		;SET LINE NUMBER FIELD IN AR
	CALL	SETLPF		;SET LINE PTR FIELD TO NEXT LINE

;SEQUENCE AROUND THE RAF TO SERVICE THE NEXT ACTIVE FUNCTION

NXTAF:	GET	CAR,RRF		;FETCH RIGHT RING FIELD
SAR:	HRRZ	B,(CAR)		;FETCH DZADR OF NEW CAR
	GET	TOP,TOPF	;FETCH TOP PTR
	HRLI	TOP,B		;INDEX BY DZADR OF CAR

;CHECK WHETHER THE CURRENT LINE NUMBER IS LESS THAN 1 OR GREATER THAN THE
;   NUMBER OF STATEMENTS IN THE FUNCTION.  IF SO, PERFORM A RETURN FROM
;   THE FUNCTION.

CHKLIR:	MOVE	L,@TOP		;FETCH TOP LEXEME
	LGET	R,IACTF		;EXTRACT INTERPRETER ACTION FIELD
	CAIE	R,CXTWD		;SYSTEM ERROR IF NOT A CONTEXT WORD
	ERROR	MSG(CXTEX)	;CXTWD EXPECTED, NOT FOUND
	GET	R,LNF		;FETCH CURRENT LINE NUMBER
	JUMPLE	R,RFF		;RETURN FROM FUNCTION IF NONPOSITIVE
	GET	B,FNF		;FETCH FUNCTION FIELD
	HRRZ	B,(B)		;GET DZADR OF FUNCTION BLOCK
	GET	R2,LINESF	;GET NO. OF LINES IN FN, INCLUDING LINE 0
	HRRZ	B,(CAR)		;RESTORE DZADR OF CAR
	CAML	R,R2		;DOES THE REFERENCED LINE EXIST?
	JRST	RFF		;NO, RETURN FROM FUNCTION

;NOW BRANCH ON THE TYPE OF THE CONTEXT WORD CURRENTLY RESIDING ON THE TOP
;   OF THE STACK.

	LGET	R2,LTYPF	;FETCH LEXEME TYPE FIELD
	HLRZ	R2,CWTBL2(R2)	;FETCH LH DISPATCH ENTRY FOR LEXEME TYPE
	JRST	(R2)		;DISPATCH

;CXTWD DISPATCH TABLE.  LH ENTRIES USED AT CHKLIR, RH IN GOTO SYSTEM FN

CWTBL2:	CKFSCP	,, GOBOT	;FOR CONTEXT WORD
	CKSTOP	,, GOBOT	;BOTTOM CONTEXT WORD
	IMPCXT	,, GODMD	;DEMAND CONTEXT WORD
	IMPCXT	,, GOSUS	;SUSPEND CONTEXT WORD
;FOR CONTEXT WORD WAS ON STACK.  CHECK TO SEE WHETHER WE HAVE EXCEEDED
;   THE SCOPE OF THE INNERMOST FOR, AND DELETE THE FOR CONTEXT IF SO.
;   R STILL CONTAINS CURRENT LINE NUMBER.

CKFSCP:	HRRZ	R2,@TOP		;FETCH LOWER BOUND OF CURRENT FOR SCOPE
	CAIGE	R,(R2)		;ARE WE ABOVE THE LOWER BOUND?
	SOJA	TOP,FSCPOP	;NO, GO POP CURRENT FOR CONTEXT
	SUBI	TOP,1		;YES, POINT TO UPPER BOUND (TARGET)
	HRRZ	R2,@TOP		;FETCH UPPER BOUND
	CAIG	R,(R2)		;PAST END OF FOR SCOPE?
	AOJA	TOP,CKSTOP	;NO, GO EXECUTE LINE AS USUAL, RESTORING TOP

;POP OFF TOPMOST FOR SCOPE.

FSCPOP:	SUBI	TOP,4		;POP OFF   I  S  U  T    (CXTWD ALREADY GONE)
	SET	TOP,TOPF	;STORE UPDATED TOP FIELD
	JRST	CHKLIR		;GO DO SCOPE CHECK AGAIN.

;CODE TO CHECK FOR A STOP CODE SET ON THE CURRENT LINE.  IF SO, PERFORM
;   USER SUSPENSION AND GO CONVERSE WITH THE USER.  ELSE, BEGIN EXECUTION
;   OF LINE.

CKSTOP:	CALL	SETLPF		;SET LINE PTR FIELD KNOWING ONLY LINE NO.
	SKIPE	SUSPND		;CHECK FOR USER SUSPENSION
	JRST	STOP1		;SUSPENDED.  GO CONVERSE WITH USER
	GET	R,LPF		;FETCH LINE PTR FIELD
	HRRZ	R,(R)		;GET DZADR OF CURRENT LINE
	MOVSI	R2,(STPBIT)	;SETUP STOP BIT FOR TEST
	TDNN	R2,1(R)		;IS THE STOP BIT SET?
	JRST	SETPM2		;NO.  GO INITIALIZE PMF AND BEGIN EXECUTION
STOP1:	SETZM	SUSPND		;CLEAR USER SUSPENSION FLAG
	MOVEI	CPM,2		;YES, SET PMF TO BEGINNING OF LINE
	SET	CPM,PMF
	TTOS	[SIXBIT/STOPPED BEFORE EXECUTING !/]
	CALL	PWHERE		;PRINT FUNCTION NAME AND LINE NUMBER
	TTOS	[SIXBIT/#/]
	CALL	CXTSAV		;STACK SUSPEND CONTEXT WORD WITH CPM AND LPF
	JRST	GTLN		;CONVERSE WITH USER IN ENV OF SUSPENSION
;CODE TO RETURN FROM USER FUNCTION.  REMOVE CALLER FROM RSF AND PLACE
;   ON RAF.  REMOVE CALLEE FROM RAF.  PASS VALUE OF CALLEE PROCID TO
;   CALLER STACK AS VALUE OF FUNCTION CALL.  RESUME EXECUTION OF CALLER.

RFF:	GET	AC1,CRF		;FETCH CALLER FIELD
	JUMPN	AC1,.+2		;SYSTEM ERROR IF NO CALLER
	ERROR	MSG(RTGLB)	;ATTEMPTED TO RETURN FROM GLOBAL ENV
	MOVEI	AC2,RSF		;OK, DELETE CALLER FROM RSF
	CALL	DELETE
	MOVEI	AC2,RAF		;INSERT CALLER ONTO RAF
	CALL	INSIRT
	EXCH	CAR,AC1		;MAKE CALLER BE CURRENT AR NOW
	CALL	DELETE		;DELETE CALLEE FROM RAF
	MOVEM	CAR,RAF		;MAKE CALLER BE EXECUTED NEXT ON RING
	SKIPN	R,ARBASE(B)	;FETCH PROCID OF CALLEE
	MOVE	R,NULLL		;IF UNASSIGNED, SUPPLY NULL
	HRRZ	B,(CAR)		;SETUP DZADR OF CALLER
	GET	TOP,TOPF	;SETUP TOP POINTER
	HRLI	TOP,B		;INDEX BY CAR DZADR
	MOVEM	R,@TOP		;STORE VALUE OF FN CALL ON CALLER STACK
	CAMN	R,NULLL		;WAS RESULT NULL?
	TRZA	FF,PIR		;YES, DON'T PRINT NULL-VALUED FNS
	IORI	FF,PIR		;NO, SET TO PRINT RESULT
	JRST	INTPGO		;GO RE-ENTER INTERPRETER TO RESUME CALLER

	SUBTTL	SYSTEM FUNCTION RETURN

SRETUR:	EXP	-1		;MAY TAKE EITHER 0 OR 1 ARG
	GET	AC1,CRF		;FETCH CALLER FIELD
	JUMPN	AC1,.+2		;MAKE SURE ONE EXISTS
	EXERR	MSG(RTGLB)	;ATTEMPTED TO RETURN FROM GLOBAL ENV
	HLRZ	R,S		;GET NUMBER OF ARGS
	JUMPE	R,GOINT		;NO ARGUMENTS, PERFORM GOTO 0 INTERPRETATION
	CAIE	R,1		;ERROR IF MORE THAN 1 ARG
	SFNERR	MSG(WNARG)	;WRONG NUMBER OF ARGS
	MOVE	L,@ARGP		;GET LEXEME
	LGET	T,LTYPF		;GET THE LEXEME TYPE FIELD
	CAILE	T,3		;IS IT IN THE HEADER WORD
	JRST	RETVAL		;JUST GO RETURN VALUE
	ADDI	L,ARBASE(B)	;COMPUTE ABS ADDRESS OF HEADER WORD
	MOVE	L,(L)		;GET THE LEXEME
	LGET	T,LTYPF		;GET ITS TYPE
	CAIE	T,12		;IS IT A DUMREF
	JRST	RETVAL		;GO RETURN VALUE
	GET	AC1,CRF		;GET ADDRESS OF CALLER
	CAIE	AC1,(L)		;SAME AS VALUE STORED IN DUMREF?
	JRST	RETVAL		;RETURN THE DUMREF
	FETCH	(R,L,FCHNF)	;GET THE OFFSET OF THE HEADER WORD
	JUMPN	R,RTFMLC	;IF ZERO, THEN IS THE FUNCTION HEADER
	HRRZI	L,1		;MAKE A PROCID LEXEME
	JRST	RETVAL
RTFMLC:	HRRZ	AC1,(AC1)	;GET DZ ADDRESS OF AR
	HLRZ	AC1,1(AC1)	;GET FN FIELD
	HRRZ	AC1,(AC1)	;GET DZ ADR OF FN
	HLRZ	AC1,3(AC1)	;GET LINE0 ADR
	HRRZ	AC1,(AC1)	;GET DZ ADDR OF LINE 0
	HLRZ	AC1,2(AC1)	;GET HWD WITH # OF FORMALS
	LSH	AC1,-6		;ISOLATE NUMBER OF FORMALS FIELD
	TRZ	AC1,4000	;CHECK FOR TUPLED ARGUMENTS
	HRRZ	L,R		;GET OFFSET
	HRLZI	L,2		;ASSUME IT IS A FORMAL
	CAMLE	AC1,R		;TEST TO SEE IF LOCAL
	HRLZI	L,3		;YES

RETVAL:	MOVEM	L,ARBASE(B)	;STORE VALUE IN THE FUNCTION HEADER
	SETZ	R,		;MAKE GOTO 0
	JRST	GOINT		;DO GOTO 0
	SUBTTL	SYSTEM FUNCTIONS FOR PROGRAM CONTROL

;CONDITIONAL GOTO

SCGOTO:	EXP	2		;TAKES TWO ARGS
	CALL	GRAB2		;FETCH TWO ATOMIC ARGUMENTS
	CAIN	AC3,U.BOOL/2	;LH MUST BE BOOL
	CAIE	T,U.INT/2	;RH MUST BE INT (OR RELOC)
	ILLTYP			;IMPROPER ARG TYPE
	JUMPE	AC1,RETNUL	;OK.  JUST EXIT IF LH IS FALSE
	AOJA	TOP,GOINT	;TRUE. POINT TOP TO RH ARG FOR TRACING
				;  AND ENTER GOTO INTERPRETER

;UNCONDITIONAL GOTO

SUGOTO:	EXP	1		;TAKES ONE ARG
	CALL	GRAB1		;FETCH ONE ATOMIC ARG
	CAIE	T,U.INT/2	;ERROR IF NOT OF TYPE INT
	ILLTYP

;PERFORM GOTO INTERPRETATION.  TARGET LINE NUMBER IS IN R.  SEARCH DOWN
;   THE AR STACK UNTIL WE FIND A BOTTOM OR FOR CONTEXT WORD, THEN
;   SET THE TARGET LINE NUMBER INTO THE LINE NUMBER FIELD AND RESUME
;   INTERPRETATION AT THE NEW LEVEL.

GOINT:	MOVE	P,[IOWD STKLEN,SYSSTK]	;RESET SYSTEM STACK
	HRRE	AC2,R		;COPY TARGET LINE NUMBER
	CAME	AC2,R		;CHECK FOR MAGNITUDE OUTSIDE 2^18
	SETZ	AC2,		;RIDICULOUS LINE NO., ASSUME ZERO
	CALL	TRCIRQ		;TRACE IF REQUIRED

;HERE TO SEARCH DOWN FOR NEXT CONTEXT WORD AND BRANCH ON IT.

GOSRC:	CALL	CXTSRC		;FIND TOPMOST CONTEXT WORD AND SET TOP
	MOVE	L,@TOP		;FETCH CONTEXT WORD
	LGET	R,LTYPF		;EXTRACT LEXEME TYPE FIELD
	HRRZ	R,CWTBL2(R)	;FETCH RH DISPATCH ENTRY FOR CXTWD TYPE
	JRST	(R)		;DISPATCH
;TOP LEXEME WAS SUSPEND CONTEXT WORD.  CHECK THE RH.  IF IT IS ZERO,
;   THEN THE USER ATTEMPTED TO EXECUTE A GOTO IN THE GLOBAL ENVIRONMENT,
;   WHICH IS AN ERROR.  OTHERWISE, POP THE CONTEXT AND RESUME SEARCHING
;   UP THE STACK.

GOSUS:	TRNN	L,-1		;ERROR IF NO PREVIOUS CONTEXT
	SFNERR	MSG(GOGLB)	;GOTO ILLEGAL IN GLOBAL ENVIRONMENT

;TOP LEXEME WAS DEMAND CONTEXT WORD

GODMD:	SUBI	TOP,1		;POP TOP LEXEME (CXTWD)
	SET	TOP,TOPF	;SET UPDATED TOP FIELD
	JRST	GOSRC		;SEARCH FOR NEXT CONTEXT WORD

;TOP LEXEME WAS BOTTOM OR FOR CONTEXT WORD.  SET THE TARGET OF THE GOTO
;   INTO THE CURRENT LINE NUMBER FIELD AND BEGIN A STATEMENT.

GOBOT:	SET	AC2,LNF		;SET LINE NUMBER FIELD
	MOVEI	CPM,2		;SET POS MKR TO BEGINNING OF LINE
	SET	CPM,PMF
	JRST	NXTAF		;GO SERVICE NEXT ACTIVE FN ON RAF


;RESUME SYSTEM FUNCTION
;   SEARCH DOWN FOR THE TOPMOST CONTEXT WORD.  IF IT IS NOT A SUSPEND
;   CONTEXT WORD, THEN ERROR.  OTHERWISE, RESTORE PREVIOUS CONTEXT AND
;   RESUME EXECUTION

SRESUM:	EXP	0		;PARAMETERLESS PROCEDURE
	CALL	CXTSRC		;RESET TOP TO TOPMOST CONTEXT WORD
	MOVE	L,@TOP		;FETCH TOP LEXEME
	LGET	R,LTYPF		;FETCH LEXEME TYPE FIELD
	CAIE	R,SUSCWD	;IF NOT SUSPEND CXTWD, THEN ERROR
	SFNERR	MSG(PRGNS)	;PROGRAM WAS NOT SUSPENDED
	TRNN	L,-1		;ERROR IF NO PREVIOUS CONTEXT TO RESTORE
	SFNERR	MSG(GLBEN)	;GLOBAL ENVIRONMENT - NOTHING TO RESUME
	CALL	CXTRST		;OK, RESTORE CONTEXT FROM SUSCWD
	SUBI	TOP,1		;UNSTACK CONTEXT WORD
	SET	TOP,TOPF
	MOVE	P,[IOWD STKLEN,SYSSTK]	;RESET SYSTEM STACK
	JRST	INTPGO		;RESUME INTERPRETATION

	SUBTTL	UTILITY ROUTINES FOR THE SUPERVISOR


;PRINT IF REQUIRED
;   ASSUMPTIONS UPON ENTRY
;    B=DZADR OF CURRENT ACTIVATION RECORD
;    TOP POINTS TO TOP OF CAR STACK
;   SAFE ROUTINE (DEFINITION: A "SAFE" ROUTINE IS ONE
;          WHICH HAS NO SIDE EFFECTS ON THE CONTENTS OF THE ACCUMULATORS).


PNTIRQ:	TRNN	FF,PIR		;CHECK IF PRINT FLAG ON
	POPJ	P,		;EXIT IF NOT REQUIRED TO PRINT
	SAVE	<AC1>		;ELSE SAVE ACCUMULATOR 1
	MOVE	AC1,@TOP	;AC1_LEXEME TO BE PRINTED
	PUSHJ	P,PRINT		;PRINT IT
	TTOA	[BYTE(7)CR,LF]	;PRINT CARRIAGE RETURN
	JRST	X1		;RESTORE AC1 AND RETURN


;TRACE IF REQUIRED
;   ASSUMPRIONS UPON ENTRY:
;    B=DZADR OF CAR
;    LNF(CAR)=CURRENT LINE NUMBER (IF APPLICABLE)
;    LPF(CAR)=CURRENT LINE PZADR
;    FNF(CAR)=CURRENT FUNCTION  (IF APPLICABLE)
;    TOP POINTS TO TOP OF CAR STACK AT VALUE OF LINE
;   SAFE ROUTINE.


TRCIRQ:	SAVE	<AC1>		;PROTECT AN AC
	GET	AC1,LPF		;FETCH CURRENT LINE PTR FIELD
	HRRZ	AC1,(AC1)	;GET DZADR OF LINE BLOCK
	MOVSI	R,(TRCBIT)	;SETUP TRACE BIT FOR TEST
	TDNN	R,1(AC1)	;IS TRACE BIT SET
	JRST	X1		;NO, RETURN RESTORING AC1
	CALL	PWHERE		;ELSE PRINT FUNCTION NAME AND LINE NO.
	TTOI	" "		;PRINT SPACE
	MOVE	AC1,@TOP	;AC1_TOPMOST LEXEME
	PUSHJ	P,PRINT		;PRINT IT
	TTOA	[BYTE(7)CR,LF]	;PRINT CARRIAGE RETURN
	JRST	X1		;RESTORE AC1 AND RETURN

;PRINT IF REQUIRED, TRACE IF REQUIRED AND UNSTACK
;   ASSUMPTIONS UPON ENTRY:
;    B=DZADR OF CAR
;    TOP POINTS TO TOP OF STACK
;    AND LNF,FNF, AND LPF SET UP AT ENTRY
;   TOP AND TOPF RESET AT EXIT

PNTTRC:	PUSHJ	P,PNTIRQ	;PRINT IF REQUIRED
	PUSHJ	P,TRCIRQ	;TRACE IF REQUIRED
	SUBI	TOP,1		;AND UNSTACK
	SET	TOP,TOPF
	POPJ	P,

;PRINT STOP MESSAGE
;CHECKS WHETHER STOPPED IN DIRECT STATEMENT OR NOT AND
;PRINTS APPROPRIATE MESSAGE.
;	PUSHJ	P,PNTSTP
;	  ;NON-SKIP RETURN--NOTHING TYPED (DIRECT STATEMENT)
;	;SKIP RETURN--"STOPPED IN F[N]" TYPED
;   SAFE ROUTINE


PNTSTP:	GET	R,LPF		;FETCH CURRENT LINE PTR FIELD
	JUMPE	R,CPOPJ		;JUMP IF NO CURRENT LINE
	HRRZ	B,(R)		;FETCH DZADR OF CURRENT LINE
	GET	R,NF		;FETCH LINE NUMBER FIELD
	HRRZ	B,(CAR)		;RESTORE BASE OF CAR
	JUMPLE	R,CPOPJ		;JUMP IF IMMEDIATE EXECUTION
	TTOS	[SIXBIT/STOPPED IN !/]
	CALL	PWHERE		;PRINT FUNCTION NAME AND LINE NUMBER
	TTOS	[SIXBIT/#/]	;SPACE TO NEXT LINE
	JRST	CPOPJ1		;SKIP RETURN TO INDICATE WE TYPED SOMETHING
;PRINT FUNCTION NAME AND LINE NUMBER
;   ASSUMPTIONS UPON ENTRY:
;    B=DZADR OF CAR , AND FNF AND LNF SET UP IN CAR AS REQUIRED
;   SAFE ROUTINE

PWHERE:	SAVE	<AC1>
	GET	AC1,FNF		;AC1_PZADR OF FUNCTION
	HRRZ	AC1,(AC1)	;GO FETCH FUNCTION IDENTIFIER
	HLRZ	AC1,3(AC1)	;RELATIVE ADDRESS IN IDT
	HRRZ	AC1,(AC1)	;AND STORE IN AC1
	HLRZ	AC1,4(AC1)
	PUSHJ	P,IDPR		;PRINT FUNCTION IDENTIFIER
	GET	AC1,LNF
	TTOI	"["		;PRINT LEFT BRACKET
	CALL	INTPR		;PRINT LINE NUMBER
	TTOI	"]"		;PRINT RIGHT BRACKET
	JRST	X1		;RESTORE AC1 AND RETURN

;STACK SUSPENSION CONTEXT WORD WITH CURRENT POSITION
;MARKER AND LINE POINTER.
;   ASSUMPTIONS UPON ENTRY:
;    B=DZADR OF CAR
;    TOP POINTS TO CURRENT TOP OF CAR STACK
;   SAFE ROUTINE (EXCEPT FOR R)


CXTSAV:	SAVE	<AC1>
	GET	R,PMF		;GET CURRENT POSITION MARKER
	GET	AC1,LPF		;AC1_CURRENT LINE POINTER
	HRLI	AC1,(LXM(CXTWD,SUSCWD,0));LHS(AC1)_CXTWD,SUSCWD
	STORE	(R,AC1,FCHNF)	;SET FORWARD CHAIN FIELD OF AC1 TO CPM
	PUSHJ	P,STACK		;STACK THE SUSCWD
	JRST	X1		;RESTORE AC1 AND RETURN
;SEARCH FOR TOPMOST CONTEXT WORD
;   ASSUMPTIONS UPON ENTRY:
;    B=DZADR OF CAR
;    TOP POINTS TO CURRENT TOP OF CAR STACK
;   AFFECTS TOP AND TOPF, ALL OTHER ACC'S SAFE.

CXTSRC:	SAVE	<L>
CXTS1:	MOVE	L,@TOP		;L_TOPMOST LEXEME
	LGET	L,IACTF		;L_INTERPRETER ACTION
	CAIE	L,CXTWD		;SKIP IF WAS CONTEXT WORD
	SOJA	TOP,CXTS1	;GO AROUND IF DIDN'T FIND CXTWD
	SET	TOP,TOPF	;RESET TOP FIELD
	RESTORE	<L>
	POPJ	P,

;RESTORE LINE POINTER FIELD
;(NAMELY: FIND LINE POINTER AND SET LINE POINTER FIELD GIVEN THE FNF, AND LNF)
;   ASSUMPTIONS UPON ENTRY:
;    B=DZADR OF CAR
;    FNF AND LNF OF CAR SET AS REQUIRED
;   SAFE ROUTINE.

SETLPF:	GET	R,FNF		;R_PZADR OF CURRENT FUNCTION
	GET	R2,LNF		;R2_CURRENT LINE NUMBER
	HRRZ	R,(R)		;R_DZADR OF FN BLOCK
	ROT	R2,-1		;SHIFT LINE NO. RIGHT ONE
	ADDI	R2,3(R)		;POINT TO LINE ENTRY
	JUMPGE	R2,.+2		;SKIP ON PARITY BIT
	SKIPA	R2,(R2)		;GET RHS
	MOVS	R2,(R2)		;GET LHS
	SET	R2,LPF		;LPF_LINE POINTER
	POPJ	P,		;EXIT
;RESTORE LINE POINTER FIELD AND CURRENT POSITION MARKER
;FROM CONTEXT WORD
;   ASSUMPTIONS UPON ENTRY
;    B=DZADR OF CAR
;    TOP POINTS TO TOP OF CAR STACK
;   RESETS CL AND CPM, ALL OTHER ACC'S ARE SAFE

CXTRST:	FETCH	(CPM,@TOP,FCHNF) ;CPM_PREVIOUS POSITION MARKER
	SET	CPM,PMF		;SET POSITION MARKER FIELD
	HRRZ	CL,@TOP		;CL_RIGHT HALF OF CONTEXT WORD, I.E.
	SET	CL,LPF		;PREVIOUS LINE POINTER PZADR
	HRRZ	CL,(CL)		;RESET LINE POINTER FIELD
	HRLI	CL,CPM		;CL_DZADR OF LINE INDEXED BY CPM
	POPJ	P,


;INCREMENT CONTROLLED VARIABLE
;   ARSSUMPTIONS UPON ENTRY
;    ARGP POINTS TO CONTROLLED VARIABLE ON STACK
;    TOP POINTS TO TOP OF STACK
;   B=DZADR OF CAR
;   SAFE ROUTINE (EXCEPT FOR R)

INCVAR:	SAVE	<AC1,S,ARGP>
	MOVE	AC1,@ARGP	;STACK CONTROLLED VARIABLE ,I , TWICE
	PUSHJ	P,STACK		;(I,I)
	PUSHJ	P,STACK
	ADDI	ARGP,1		;STACK STEP ELEMENT, S
	MOVE	AC1,@ARGP
	PUSHJ	P,STACK
	HRRZI	S,%ADD		;ADD I+S AND STORE SUM
	PUSHJ	P,EXCT		;ON STACK
	SAVE	<FF>		;SAVE PRESENT STATE OF PIR FLAG
	HRRZI	S,%ASSIGN
	PUSHJ	P,EXCT		;DO ASSIGNMENT I_(I+S)
	RESTOR	<FF>		;RESTORE STATE OF FLAGS (PIR CLEARED BY ASSIGN)
	SUBI	TOP,1		;AND UNSTACK
	SET	TOP,TOPF	;RESET TOPF OF CAR
	RESTORE	<ARGP,S,AC1>
	POPJ	P,
;CHECK "FOR" CONTROL ELEMENTS ON STACK TO VERIFY
;PROPER TYPE AND TO COERCE TO CONSTANTS, BEFORE
;EXECUTING "FOR" STATEMENT OR "FOR" FORM.
;   ASSUMPTIONS UPON ENTRY
;    B=DZADR OF CAR
;    ARGP POINTS TO CONTROLLED VARIABLE ON CAR STACK

FORLCK:	SAVE	<AC1,T,ARGP>
	MOVE	AC1,@ARGP	;SAVE CONTROLLED VARIABLE LEXEME IN AC1
	PUSHJ	P,ARGPRP	;COERCE TO CONSTANT,TYPE IN T
	  JRST	  .+2		;ERROR IF NON-ATOMIC
	CAILE	T,U.DBL/2	;SKIP IF LOWER BOUND WAS ARITHMETIC
	EXERR	MSG(LLFOR)	;LOWER LIMIT OF "FOR" NOT ARITHMETIC
	MOVEM	AC1,@ARGP	;MOVE CONTROLLED VARIABLE LEXEME BACK ON STACK
	ADDI	ARGP,1
	PUSHJ	P,MKCNST	;COERCE STEP ELEMENT TO CONSTANT
	  JRST	  .+4		;ERROR
	PUSHJ	P,ARGPRP	;GET TYPE OF STEP ELEMENT IN T
	  JRST	  .+2		;ERROR IF NON-ATOMIC
	CAILE	T,U.DBL/2	;SKIP IF STEP ELEMENT WAS ARITHMETIC
	EXERR	MSG(STFOR)	;STEP ELEMENT OF "FOR" NOT ARITHMETIC
	ADDI	ARGP,1
	PUSHJ	P,MKCNST	;COERCE UPPER LIMIT TO CONSTANT
	  JRST	  .+4		;ERROR
	PUSHJ	P,ARGPRP	;GET TYPE OF UPPER LIMIT IN T
	  JRST	  .+2		;ERROR IF NON-ATOMIC
	CAILE	T,U.DBL/2	;SKIP IF UPPER LIMIT WAS ARITHMETIC
	EXERR	MSG(ULFOR)	;UPPER LIMIT OF "FOR" NOT ARITHMETIC
	RESTORE	<ARGP,T,AC1>	;RESTORE ACCUMULATORS, AND
	POPJ	P,		;EXIT
;CHECK RANGE OF FOR CONTROLLED VARIABLE
;   NORMAL RETURN - CONTROLLED VARIABLE WAS IN RANGE
;   SKIP   RETURN - CONTROLLED VARIABLE WAS OUT OF RANGE
;
;   ASSUMPTIONS UPON ENTRY:
;    ARGP POINTS TO CONTROLLED VARAIBLE
;    TOP POINTS TO TOP OF CAR STACK
;    B=DZADR OF CAR

RNGCHK:	SAVE	<AC1,S,ARGP>
	MOVE	AC1,@ARGP	;STACK CONTROLLED VARIABLE, I
	PUSHJ	P,STACK
	ADDI	ARGP,2		;STACK UPPER LIMIT, U
	MOVE	AC1,@ARGP
	PUSHJ	P,STACK
	HRRZI	S,%SUB
	PUSHJ	P,EXCT		;COMPUTE (I-U) ON TOP OF STACK
	MOVE	ARGP,TOP	;SET ARGP TO TOP
	PUSHJ	P,ARGPRP	;COERCE (I-U)TO CONSTANT IN R,R2; TYPE IN T
	  ERROR	  MSG(FCVNA)	;"FOR" CONTROLLED VARIABLE NOT ARITHMETIC
	SUBI	TOP,1		;UNSTACK
	SET	TOP,TOPF
	JUMPE	R,NOTOUT	;IF I=U GO TO NOT OUT OF RANGE EXIT
	MOVE	AC1,R		;ELSE SAVE FIRST WORD OF (I-U) IN AC1
	MOVE	ARGP,(P)	;REFRESH ARGP
	ADDI	ARGP,1		;POINT ARGP AT STEP ELEMENT S
	PUSHJ	P,ARGPRP	;GET SIGN OF STEP ELEMENT
	  ERROR	  MSG(SENCN)	;STEP ELEMENT NOT COERCED TO CONSTANT IN "FOR"
	XOR	R,AC1		;EXCLUSIVE OR THE SIGN BITS OF STEP AND (I-U)
	TLNN	R,400000	;CHECK SIGN OF RESULT
	AOS	-3(P)		;SKIP RETURN TO GO OUT OF RANGE

;NORMAL RETURN IF CONTROLLED VARIABLE STILL IN RANGE

NOTOUT:	RESTORE	<ARGP,S,AC1>
	POPJ	P,		;RESTORE ACC'S AND EXIT
;ROUTINE TO INSERT AN ACTIVATION RECORD INTO A RING.
;	AC1 =	PZADR OF ACTIVATION RECORD
;	AC2 =	ADR OF RING REFERENT (RAF OR RSF)

INSIRT:	SAVE <B,AC3,AC4>
	MOVE	AC3,(AC2)	;AC3_CONTENTS OF RING ADDRESS
	JUMPE	AC3,INS1	;IF RING=0 THEN WAS EMPTY,GO TO INS1
	HRRZ	B,(AC3)		;B_DZADR OF RING REFERENT
	GET	AC4,LRF		;AC4_LFT NBR OF RING REFERENT
	SET	AC1,LRF		;LFT NBR[RING REFERENT]_AR
	HRRZ	B,(AC1)		;B_DZADR OF AR
	SET	AC3,RRF		;RT NBR(AR)_RING REF
	SET	AC4,LRF		;LFT NBR(AR)_LFT NBR OF RING REFERENT
	HRRZ	B,(AC4)		;B_DZADR OF LFT NBR OF RING REF
	SET	AC1,RRF		;RT NBR(LFT NBR)_AR
INS2:	RESTOR <AC4,AC3,B>
	POPJ	P,
INS1:	HRRZ	B,(AC1)		;B_DZADR OF AR
	SET	AC1,LRF		;LFT NBR OF AR_AR
	SET	AC1,RRF		;RT NBR OF AR _ AR
	MOVEM	AC1,(AC2)	;RING ADDRESS_AR
	JRST	INS2		;EXIT
;ROUTINE TO DELETE AN AR (WHOSE PZADR IS IN AC1)
;FROM THE RING (WHOSE LOW SEG ADDRESS IS IN AC2).

DELETE:	SAVE <AC3,AC4,AC5,B>
	MOVE	AC3,(AC2)	;AC3_RING REF
	JUMPE	AC3,DEL2	;GO OUT IF RING EMPTY
	MOVE	AC4,AC3		;COPY RING REF IN AC4
DEL3:	CAMN	AC4,AC1		;SEE IF AR WAS ON RING
	JRST	DEL1		;GO TO DEL1 IF AR WAS ON RING
	HRRZ	B,(AC4)		;AC4_LEFT NBR OF AC4
	GET	AC4,LRF
	CAME	AC4,AC3		;IF WENT ALL THE WAY AROUND RING
	JRST	DEL3		;AND AR WASN'T ON IT, GO OUT
DEL2:	RESTOR <B,AC5,AC4,AC3>
	POPJ	P,		;RESTORE AND EXIT
DEL1:	HRRZ	B,(AC3)		;B_DZADR OF RING REF
	GET	AC4,LRF		;SKIP IF THERE WAS ONLY ONE
	CAME	AC4,AC3		;ONE MEMBER OF THE RING
	JRST	DEL4		;ELSE GO TO DEL4
	SETZM	(AC2)		;ZERO OUT RING ,I.E. SET IT TO EMPTY
	JRST	DEL2		;AND GO OUT
DEL4:	HRRZ	B,(AC1)		;B_DZADR OF AR
	GET	AC4,LRF		;AC4_LFT NBROF AR
	GET	AC5,RRF		;AC5_RT NBR OF AR
	HRRZ	B,(AC4)		;B_DZADR OF LFT NBR
	SET	AC5,RRF		;RT NBR(LFT NBR)_RT NBR(AR)
	HRRZ	B,(AC5)		;B_DZADR RT NBR
	SET	AC4,LRF		;LFT NBR(RT NBR)_LFT NBR (AR)
	CAME	AC3,AC1		;SKIP IF RING REF=AR
	JRST	DEL2		;ELSE GO OUT
	MOVEM	AC4,(AC2)	;RING_LFT NBR(AR)
	JRST	DEL2		;EXIT

;THE FOLLOWING ROUTINE STACKS THE CONTENTS OF AC1 ON TOP OF THE
;CAR STACK AND EXTENDS THE STACK IF THERE IS NOT ENOUGH STACK SPACE.
;ENTER WITH B=DZADR OF CAR

STACK:	GET	R,WLF		;R_WLENGTH OF CAR
	ADDI	TOP,1		;INCREMENT TOP POINTER BY ONE
	CAIG	R,(TOP)		;IF TOP >= WLENGTH
	JRST	ST1		;THEN STACK OVERFLOW
STACK1:	MOVEM	AC1,@TOP	;ELSE STORE (AC1) IN TOP OF STACK
	SET	TOP,TOPF	;RESET TOP FIELD OF CAR
	POPJ	P,		;AND EXIT

ST1:	SKIPE	JOBDDT		;GIVE WARNING MSG IF DDT IS LOADED
	OUTSTR	[ASCIZ/[STACK EXTENDED]
/]
	SAVE	<AC1,AC2>	;PROTECT AC'S USED IN CALL TO EXTEND
	MOVE	AC1,CAR		;SET UP ARGUMENTS FOR EXTEND
	MOVEI	AC2,STKXTL	;SETUP AMOUNT TO LENGTHEN BY
	PUSHJ	P,EXTEND	;EXTEND CAR
	RESTORE	<AC2,AC1>
	HRRZ	B,(CAR)		;RECOMPUTE DZ BASE ADR OF CAR
	GET	R,LPF		;AND RECOMPUTE LINE POINTER TO
	HRR	CL,(R)		;CURRENT LINE INDEXED BY PM
	JRST	STACK1		;NOW GO STACK
;ROUTINE TO SEQUENCE DOWN AN ARGLIST, CALLING THE ROUTINE WHOSE ADDRESS
;   IS IN AC1 FOR EACH ARG.   THE FOLLOWING INFORMATION IS AVAILABLE
;   TO THE CALLEE:
;	R: LEXEME TYPE
;	L: THE LEXEME
;	B: DZADR OF CAR (RESTORED EACH TIME)
;   ENTER ASSUMING
;	ARGP =	B,,PTR(1ST ARG)
;	S[LH] =	NO. OF ARGS
;   AC1 AND AC2 ARE LEGALLY CLOBBERABLE BY THE CALLEE.
;   THE CALLEE MAY SKIP OR NON-SKIP RETURN.  ARGSEQ WILL SKIP
;   IF AND ONLY IF EVERY INVOCATION OF THE CALLEE SKIPPED.
;   NOTE THAT CALLING ARGSEQ WITH A LIST OF LENGTH ZERO WILL
;   ALWAYS RESULT IN A SKIP.

ARGSEQ:	SAVE	<S>		;STACK NUMBER OF ARGS
	HLRZS	(P)		;PUT IN RH
	JRST	ARGEN0

;ROUTINE TO ENUMERATE N ARGS, WHERE N IS IN AC2.
;   ALL OTHER DETAILS OF THE CALL AS FOR ARGSEQ.

ARGENU:	SAVE	<AC2>		;STACK NUMBER OF ARGS
ARGEN0:	SAVE	<ARGP,AC1,AC2>	;PROTECT ARG POINTER AND CALLEE ADDRESS
ARGEN1:	SOSGE	-3(P)		;CHECK ARG COUNT
	JRST	ARGENX		;NO ARGS LEFT TO DO
	HRRZ	B,(CAR)		;SET UP DZADR OF CURRENT AR
	MOVE	L,@ARGP		;GET A LEXEME
	LGET	R,LTYPF		;EXTRACT LEXEME TYPE FIELD
	CALL	@-1(P)		;CALL GIVEN ROUTINE
	  TLO	  ARGP,400000	;REMEMBER A NON-SKIP RETURN OCCURRED.
	AOJA	ARGP,ARGEN1	;GO BACK FOR MORE ARGS

;COME HERE TO EXIT FROM ARGENU

ARGENX:	TLNN	ARGP,400000	;SKIP IF ANY CALLS DID NOT SKIP
	AOS	-4(P)		;ALL CALLS SKIPPED, SO WE SKIP OURSELVES.
	RESTORE	<AC2,AC1,ARGP,R>
	JRST	BPOPJ		;RESTORE B AND RETURN



	LIT
	END