Google
 

Trailing-Edge - PDP-10 Archives - BB-FT68D-SM - exec/execp.mac
There are 47 other files named execp.mac in the archive. Click here to see a list.
;Edit 1012 to EXECP.MAC by SANTIAGO on Mon 20-Aug-84, for SPR #19652
;		Fix "FORK n" command to not blow up when "n" is
;;		an unknown fork (not in table FRKTAB)
;Edit 978 to EXECP.MAC by PRATT on Tue 27-Sep-83, for SPR #19023
;		.CINPU called SPECFN with arguement set up incorrectly.
;Edit 950 - Remove edit 908
;Edit 946 - Don't allow multiple /USE-SECTION: switch on GET,RUN and DDT commands
; UPD ID= 97, FARK:<5-WORKING-SOURCES.EXEC>EXECP.MAC.3,  14-Sep-82 09:24:47 by DONAHUE
;Edit 908 - Fix the BACKGROUND subcommand to START
; UPD ID= 12, FARK:<4-1-WORKING-SOURCES.EXEC>EXECP.MAC.3,  30-Mar-82 13:04:00 by MOSER
;EDIT - 718 Fix GET class commands to not parse section switches under 4.1
; UPD ID= 10, FARK:<4-1-WORKING-SOURCES.EXEC>EXECP.MAC.2,  30-Mar-82 12:50:27 by MOSER
;EDIT 717 - Use SFORK when running under 4.1.
; UPD ID= 135, SNARK:<5.EXEC>EXECP.MAC.16,  29-Jan-82 14:11:51 by WALLACE
;TCO 5.1707 - Make START command always use XSFRK% (never SFORK%) when
;  user gives an octal address
; UPD ID= 123, SNARK:<5.EXEC>EXECP.MAC.11,  28-Dec-81 11:15:38 by CHALL
;TCO 5.1644 - UPDATE COPYRIGHT NOTICE
; UPD ID= 105, SNARK:<5.EXEC>EXECP.MAC.9,   6-Nov-81 13:29:24 by CHALL
;TCO 5.1603 CHANGE THE NAME OF OP-CODE 415 FROM XHLLI TO XMOVEI
; UPD ID= 85, SNARK:<5.EXEC>EXECP.MAC.8,  10-Oct-81 19:46:01 by CHALL
;TCO 5.1564 ADD "PRESERVE (PCL ENVIRONMENT)"; DELETE SAVE/ENV AND SAVE/EXEC
; UPD ID= 80, SNARK:<5.EXEC>EXECP.MAC.7,   2-Oct-81 10:35:53 by CHALL
;TCO 5.1543 .CSAVE AND .SAVE- PUT BACK (on file) NOISES
; UPD ID= 73, SNARK:<5.EXEC>EXECP.MAC.6,  21-Sep-81 09:09:15 by CHALL
;TCO 5.1519 .FREEZ- DON'T ALLOW FORK 0 TO BE FROZEN
; UPD ID= 70, SNARK:<5.EXEC>EXECP.MAC.3,  14-Sep-81 11:08:07 by CHALL
;TCO 5.1504 ..CONT- JRST WAITR INSTEAD OF WAITF, TO DO RESCAN (THIS IS 6.1003)
; UPD ID= 68, SNARK:<5.EXEC>EXECP.MAC.2,  10-Sep-81 14:12:03 by CHALL
;TCO 5.1500 $GET0- $GET2- SET UP FORK'S SECTION (IN CODSEC) AFTER GET
;  (MOVE THE CODE TO DO THIS, MODIFIED, FROM GET1:)
; UPD ID= 59, SNARK:<5.EXEC>EXECP.MAC.16,  31-Aug-81 11:54:24 by CHALL
;TCO 5.1480 $CONT1- USE LABEL $CONF1 WHEN NOT 1ST TIME THROUGH
; UPD ID= 45, SNARK:<5.EXEC>EXECP.MAC.12,  19-Aug-81 10:39:22 by CHALL
;TCO 5.1464 .FORK- MOVE PROMPT TO EXECCA AND CHANGE FOR NOMFRK
;TCO 5.1465 .RESET- MOVE MFRK-DEPENDENT STUFF TO EXECCA
; UPD ID= 36, SNARK:<5.EXEC>EXECP.MAC.11,  14-Aug-81 19:12:56 by CHALL
;TCO 5.1454 CHANGE NAME FROM XDEF TO EXECDE
; UPD ID= 20, SNARK:<5.EXEC>EXECP.MAC.9,  21-Jul-81 12:29:22 by MURPHY
;TCO 5.1427 - Get rid of PNTMES in $GET2.
; UPD ID= 8, SNARK:<5.EXEC>EXECP.MAC.8,  13-Jul-81 17:40:46 by MURPHY
;TCO 5.1410 - OVER QUOTA, MACH SIZE EXCEEDED, ETC.
; UPD ID= 3, SNARK:<5.EXEC>EXECP.MAC.7,   9-Jul-81 18:09:57 by GRANT
;TCO 5.1405 - Do better analysis of fork termination in FRKTRM
; UPD ID= 2123, SNARK:<5.EXEC>EXECP.MAC.4,   4-Jun-81 09:51:25 by GRANT
;Add test for DSFF in ..STCR
; UPD ID= 1959, SNARK:<5.EXEC>EXECP.MAC.3,   7-May-81 11:36:02 by GROUT
;TCO 5.1317 - Make SET ADDRESS-BREAK work properly with AFTER parameter
;REMOVE MFRK CONDITIONALS
; UPD ID= 1740, SNARK:<6.EXEC>EXECP.MAC.3,  19-Mar-81 16:46:53 by OSMAN
;Make RUN FOO, ^C, DDT/USE-SECTION work
; UPD ID= 1626, SNARK:<6.EXEC>EXECP.MAC.2,   2-Mar-81 08:57:11 by OSMAN
;tco 6.1003 - Make "FOO text" pass itself to the program FOO as RSCAN data
;regardless of whether FOO is set as "KEEP CONTINUE" or "KEEP START".
;REMOVE MFRK CONDITIONALS
;<4.EXEC>EXECP.MAC.1, 29-Nov-80 16:57:40, Edit by DK32
;Programmable Command Language
; UPD ID= 1553, SNARK:<5.EXEC>EXECP.MAC.50,  11-Feb-81 10:00:38 by OSMAN
;More 5.1225 - Print ac's in octal
; UPD ID= 1551, SNARK:<5.EXEC>EXECP.MAC.49,  11-Feb-81 09:10:23 by OSMAN
;Make DDT/USE-SECTION work better (start DDT in correct section for one)
; UPD ID= 1472, SNARK:<5.EXEC>EXECP.MAC.48,  22-Jan-81 09:39:57 by OSMAN
;More 5.1225 - Don't set TRPOKF if there are errors
; UPD ID= 1438, SNARK:<5.EXEC>EXECP.MAC.47,  15-Jan-81 10:51:33 by OSMAN
;Tco 5.1233 - Make FILE-OPENINGS and JSYS OPENF independent
; UPD ID= 1417, SNARK:<5.EXEC>EXECP.MAC.46,   7-Jan-81 09:33:01 by OSMAN
;5.1225 - Fix error handling of programs bombing out
; UPD ID= 1416, SNARK:<5.EXEC>EXECP.MAC.45,   7-Jan-81 09:15:50 by OSMAN
;5.1225 again - Fix "CONTINUE fork", also don't set null traps
; UPD ID= 1415, SNARK:<5.EXEC>EXECP.MAC.44,   6-Jan-81 16:35:01 by OSMAN
; UPD ID= 1414, SNARK:<5.EXEC>EXECP.MAC.43,   6-Jan-81 16:09:13 by OSMAN
;Use .TFRAL before .TFSET
; UPD ID= 1413, SNARK:<5.EXEC>EXECP.MAC.42,   6-Jan-81 15:28:08 by OSMAN
;More 5.1225 - Handle case of fork not being us
; UPD ID= 1405, SNARK:<5.EXEC>EXECP.MAC.40,   6-Jan-81 13:42:29 by OSMAN
;Don't move "=>" (current fork) on CONTINUE command until confirmation
; UPD ID= 1400, SNARK:<5.EXEC>EXECP.MAC.39,   6-Jan-81 10:27:55 by OSMAN
;tco 5.1225 - Implement jsys trapping and file-opening trapping!
; UPD ID= 1324, SNARK:<5.EXEC>EXECP.MAC.38,   1-Dec-80 16:01:32 by OSMAN
;Use XSFRK% to start forks in non-0 sections
; UPD ID= 1269, SNARK:<5.EXEC>EXECP.MAC.37,  13-Nov-80 08:52:54 by OSMAN
; UPD ID= 1267, SNARK:<5.EXEC>EXECP.MAC.36,  12-Nov-80 14:04:50 by OSMAN
;Make "..34" be seen as a symbol and not a number
; UPD ID= 1265, SNARK:<5.EXEC>EXECP.MAC.35,  11-Nov-80 10:17:51 by OSMAN
; UPD ID= 1253, SNARK:<5.EXEC>EXECP.MAC.34,  10-Nov-80 13:24:31 by OSMAN
;Change routine CHKPAT to NOPAT, which skips if non-compatible
; UPD ID= 1244, SNARK:<5.EXEC>EXECP.MAC.33,   7-Nov-80 10:40:12 by FBROWN
;TCO 5.1192 - Make ADDNAM external so it can be called from EXECMI
;	to give the MIC fork a name
; UPD ID= 1240, SNARK:<5.EXEC>EXECP.MAC.32,   6-Nov-80 15:20:52 by OSMAN
;TCO 5.1189 - Fix error on page numbers being out of order on SAVE.
;Add /USE-SECTION: on GET.
;Use HIGHPN instead of 377777
; UPD ID= 1207, SNARK:<5.EXEC>EXECP.MAC.31,  29-Oct-80 09:57:02 by OSMAN
;More 5.1168 - Get name right of defaultly kept
; UPD ID= 1202, SNARK:<5.EXEC>EXECP.MAC.30,  27-Oct-80 10:37:32 by OSMAN
;Put in SAV9: (only needed for .DIF file compatability)
; UPD ID= 1172, SNARK:<5.EXEC>EXECP.MAC.29,  20-Oct-80 09:32:58 by OSMAN
; UPD ID= 1171, SNARK:<5.EXEC>EXECP.MAC.27,  17-Oct-80 16:43:57 by OSMAN
; UPD ID= 1170, SNARK:<5.EXEC>EXECP.MAC.26,  17-Oct-80 16:12:44 by OSMAN
;More fix for SAVE confirmation
; UPD ID= 1149, SNARK:<5.EXEC>EXECP.MAC.25,  10-Oct-80 14:51:46 by OSMAN
; UPD ID= 1147, SNARK:<5.EXEC>EXECP.MAC.24,  10-Oct-80 10:57:02 by OSMAN
;Fix SAVE confirmation to print filespec
; UPD ID= 1133, SNARK:<5.EXEC>EXECP.MAC.23,   6-Oct-80 13:35:56 by OSMAN
;More 5.1168 - Use ETYPE instead of TYPE!
; UPD ID= 1131, SNARK:<5.EXEC>EXECP.MAC.22,   6-Oct-80 10:41:05 by OSMAN
;tco 5.1168 - Announce name of fork being kept
; UPD ID= 1130, SNARK:<5.EXEC>EXECP.MAC.21,   6-Oct-80 10:16:56 by OSMAN
;tco 5.1167 - Remove FDB autokeep feature
; UPD ID= 1115, SNARK:<5.EXEC>EXECP.MAC.20,   3-Oct-80 11:32:35 by OSMAN
;tco 5.1162 - Parse program names as keywords.
; UPD ID= 1043, SNARK:<5.EXEC>EXECP.MAC.19,  25-Sep-80 14:17:15 by OSMAN
;tco 5.1156 - Add SET DEFAULT PROGRAM
; UPD ID= 1030, SNARK:<5.EXEC>EXECP.MAC.18,  22-Sep-80 10:38:28 by OSMAN
;tco 5.1150 - Add SET PROGRAM
; UPD ID= 1020, SNARK:<5.EXEC>EXECP.MAC.17,  16-Sep-80 15:37:35 by OSMAN
;tco 5.1147 - Make sure ^C from INVOKE freezes fork
; UPD ID= 1014, SNARK:<5.EXEC>EXECP.MAC.16,  15-Sep-80 09:21:40 by OSMAN
;More 5.1129 - Calculate end of symbol table correctly
; UPD ID= 916, SNARK:<5.EXEC>EXECP.MAC.15,  19-Aug-80 14:05:38 by HESS
;Fix Examine/Deposit commands for multi-forking
; UPD ID= 900, SNARK:<5.EXEC>EXECP.MAC.14,  14-Aug-80 14:26:37 by OSMAN
;More 5.1129 - Handle large symbol tables better
; UPD ID= 883, SNARK:<5.EXEC>EXECP.MAC.13,  13-Aug-80 09:20:56 by OSMAN
;Make "ST,SIGNAL" not give horrible error if no program
; UPD ID= 872, SNARK:<5.EXEC>EXECP.MAC.12,  11-Aug-80 11:21:57 by OSMAN
;5.1129 - Allow "@" in instructions
; UPD ID= 867, SNARK:<5.EXEC>EXECP.MAC.11,  11-Aug-80 10:59:36 by OSMAN
;More 5.1129 - Handle "A,,B" and (gasp...) "A,,B(C)"
; UPD ID= 861, SNARK:<5.EXEC>EXECP.MAC.10,  10-Aug-80 16:06:07 by OSMAN
;More 5.1129 - Don't clobber P1 in EVAL
; UPD ID= 857, SNARK:<5.EXEC>EXECP.MAC.9,  10-Aug-80 15:20:17 by OSMAN
;tco 5.1129 - Add symbolic address and expression support
; UPD ID= 843, SNARK:<5.EXEC>EXECP.MAC.8,   6-Aug-80 08:55:19 by OSMAN
;TCO 5.1122 - Move setting of FK%BKG to WAITA so that entry from EXECCS hits it
; UPD ID= 831, SNARK:<5.EXEC>EXECP.MAC.7,   4-Aug-80 12:37:13 by LYONS
; DETACH (AND) CONTINUE	 USES A BEFOR IT HAS DATA
; UPD ID= 705, SNARK:<5.EXEC>EXECP.MAC.6,  26-Jun-80 10:13:03 by LYONS
;After running an ephemeron, tty mode is not reset as the exec wants
; UPD ID= 702, SNARK:<5.EXEC>EXECP.MAC.5,  26-Jun-80 09:40:48 by LYONS
;WEPHM calls FKTRM1 to tell why fork stoped, but B does not have the status
; UPD ID= 545, SNARK:<5.EXEC>EXECP.MAC.4,  21-May-80 12:07:28 by MURPHY
;Change XTND to MFRK for code related to multi-fork
;<5.EXEC>EXECP.MAC.3, 13-May-80 14:43:36, EDIT BY OSMAN
;Change "finished at" to "halted at"
;<4.1.EXEC>EXECP.MAC.2, 17-Mar-80 14:36:45, EDIT BY OSMAN
;Fix SPJFN arg setup (TMPJFN)
;<4.EXEC>EXECP.MAC.62, 26-Sep-79 16:05:36, Edit by HESS
; Fix filespec typeout on SAVE command (XTND only)
;<4.EXEC>EXECP.MAC.61, 24-Sep-79 12:19:29, Edit by HESS
; Disallow NAME<CR> as a valid command.
;<4.EXEC>EXECP.MAC.59, 20-Sep-79 14:13:56, Edit by HESS
; Use perm free space for FRKTBL
;<4.EXEC>EXECP.MAC.58, 18-Sep-79 14:26:48, Edit by HESS
; Change noise words of NAME command (XTND only)
;<4.EXEC>EXECP.MAC.57, 12-Sep-79 16:25:51, Edit by HESS
; Give warning if "forking" to inferior of inferior
;<4.EXEC>EXECP.MAC.56,  5-Sep-79 10:30:12, EDIT BY OSMAN
;tco 4.2440 - Avoid "?JFN is not assigned" in TV (Don't close jfns after GET
;jsys
;<HESS.E>EXECP.MAC.47, 20-Aug-79 17:56:49, Edit by HESS
; Add extended features
;<4.EXEC>EXECP.MAC.53, 21-Jun-79 13:37:07, EDIT BY OSMAN
;REMOVE EXTRANEOUS REFS TO RLJFNS
;<4.EXEC>EXECP.MAC.52, 19-Jun-79 16:16:48, EDIT BY OSMAN
;tco 4.2297 - Fix error message when trying to save execute-only program
;<4.EXEC>EXECP.MAC.51, 14-Jun-79 14:25:38, EDIT BY OSMAN
;TCO 4.2287 - Give good error if CONTINUE fails due to SFORK
;<4.EXEC>EXECP.MAC.48,  2-May-79 10:07:10, EDIT BY OSMAN
;GET RID OF CJFN1 (ASSUMED JFN WAS FIRST ON STACK, BAD ASSUMPTION!)
;<4.EXEC>EXECP.MAC.47, 30-Apr-79 13:19:13, EDIT BY OSMAN
;MAKE FORK CREATION ONLY DO EPCAP TO TURN OFF ^C
;<4.EXEC>EXECP.MAC.46, 27-Apr-79 16:37:31, EDIT BY OSMAN
;IF CHKPAT ENCOUNTERS ERROR, BOMB OUT
;<4.EXEC>EXECP.MAC.42, 27-Apr-79 15:30:06, EDIT BY OSMAN
;FIX CHKPAT, WHICH HAD TOO MANY POP'S
;<4.EXEC>EXECP.MAC.41, 20-Apr-79 10:01:00, EDIT BY OSMAN
;MAKE FAILING CFORK NOT SAY "JSYS ERROR AT"
;<4.EXEC>EXECP.MAC.39, 28-Mar-79 14:36:56, EDIT BY OSMAN
;tco 4.2226 - Don't save prog as "MACRO.EXE" after "CONTINUE STAY"
;<4.EXEC>EXECP.MAC.38, 19-Mar-79 11:40:13, EDIT BY DNEFF
;Fix ^C, START (or REENTER, etc) of compatible programs.
;<4.EXEC>EXECP.MAC.37, 12-Mar-79 18:02:17, EDIT BY KONEN
;UPDATE COPYRIGHT FOR RELEASE 4
;<4.EXEC>EXECP.MAC.36,  6-Mar-79 09:54:43, EDIT BY OSMAN
;USE GTJFS INSTEAD OF $GTJFN
;<4.EXEC>EXECP.MAC.35, 16-Feb-79 16:31:52, EDIT BY HEMPHILL
;TCO 4.2191 -- MAKE DDT COMMAND USE UDDT WHEN COMPATABILITY PACKAGE IS PRESENT
;<4.EXEC>EXECP.MAC.34, 31-Jan-79 11:02:35, EDIT BY OSMAN
;INCLUDE SS%WR IN SSAVE ARG
;<4.EXEC>EXECP.MAC.33, 30-Jan-79 17:24:18, EDIT BY OSMAN
;CALL SETPRG before RFORK at WAITA
;<4.EXEC>EXECP.MAC.32, 26-Jan-79 15:12:17, EDIT BY OSMAN
;REMOVE PRESERVE subcommand to SAVE, and make SAVE preserve by default
;<4.EXEC>EXECP.MAC.31, 15-Jan-79 23:00:28, EDIT BY HEMPHILL
;Patch CHKPAT to preserve save AC2 over calls to LOADF
;<4.EXEC>EXECP.MAC.30, 15-Jan-79 02:41:46, EDIT BY HEMPHILL
;MAKE EXEC UNDERSTAND USER EXTENDED ADDRESSING FOR INVOLUNTARY TERMINATION
; ALSO, MAKE "START" ACCEPT A LARGE ADDRESS, EVEN IF IT CAN'T USE IT YET
;<4.EXEC>EXECP.MAC.29, 12-Jan-79 17:36:32, EDIT BY OSMAN
;REMOVE REFS TO RUNFK
;<4.EXEC>EXECP.MAC.27,  8-Dec-78 16:31:50, EDIT BY OSMAN
;PUT IN SUBCOMMANDS TO SAVE COMMAND
;<4.EXEC>EXECP.MAC.26,  4-Nov-78 01:14:22, EDIT BY OSMAN
;tco 4.2077 - Make DDT command work after "fork" command
;<4.EXEC>EXECP.MAC.25, 18-Oct-78 14:40:59, EDIT BY OSMAN
;Improve message when program halts due to system call trap
;<4.EXEC>EXECP.MAC.24, 27-Sep-78 20:22:51, EDIT BY OSMAN
;REMOVE Bn SYMBOLS
;<4.EXEC>EXECP.MAC.18, 16-Sep-78 00:12:02, EDIT BY OSMAN
;REMOVE REFS TO CSBUFP
;<4.EXEC>EXECP.MAC.17, 14-Sep-78 14:10:35, EDIT BY OSMAN
;ONLY SEARCH XDEF, TTITLE DOES REST
;<4.EXEC>EXECP.MAC.15, 12-Aug-78 16:14:14, EDIT BY OSMAN
;CHANGE FAILING SAVES TO CALL OPNERR INSTEAD OF JRSTING TO IT
;<4.EXEC>EXECP.MAC.13, 29-Jun-78 13:10:23, EDIT BY OSMAN
;SAY NOT TOPS20 COMMAND LEVEL WHEN PROGRAM BEING RUN (FOR BATCH)
;<4.EXEC>EXECP.MAC.12, 27-Jun-78 11:22:28, EDIT BY OSMAN
;CHANGE PION/PIOFF TO CALL PION/CALL PIOFF
;<4.EXEC>EXECP.MAC.11, 26-Jun-78 14:10:29, EDIT BY OSMAN
;CLEAR CIPF INSTEAD OF COMAND AT WAITA
;<4.EXEC>EXECP.MAC.10, 13-Jun-78 11:28:04, EDIT BY OSMAN
;FIX PROBLEM WHERE "/RUN:FOO" FOLLOWED BY "G" IN EDIT SAT AND WAITED FOR SUPERFLUOUS CR
;<4.EXEC>EXECP.MAC.8,  9-Jun-78 18:36:57, EDIT BY OSMAN
;USE PION/PIOFF INSTEAD OF DIR/EIR
;<4.EXEC>EXECP.MAC.7, 24-May-78 09:57:11, EDIT BY OSMAN
;CLEAR STAYF, SO "REENTER" AFTER "CONTINUE STAY" DOESN'T STAY AT @ LEVEL
;<4.EXEC>EXECP.MAC.6,  2-Mar-78 09:06:18, Edit by PORCHER
;<4.EXEC>EXECP.MAC.5,  2-Mar-78 08:52:46, Edit by PORCHER
;Add SETGO routine for CCL start (in EXECCS)
;<4.EXEC>EXECP.MAC.4, 31-Jan-78 15:17:16, Edit by PORCHER
;<4.EXEC>EXECP.MAC.3, 30-Jan-78 17:02:41, Edit by PORCHER
;<4.EXEC>EXECP.MAC.2, 30-Jan-78 14:59:14, Edit by PORCHER
;Add changes for execute-only
;<4.EXEC>EXECP.MAC.1,  7-Jan-78 15:18:31, EDIT BY HELLIWELL
;ADD HELP TEXT TO OCTX AT .START+5
;TOPS20 'EXECUTIVE' COMMAND LANGUAGE

;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1980,1981,1982 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.

	SEARCH EXECDE
	TTITLE EXECP

;THIS FILE CONTAINS
;PROGRAM COMMANDS, LIKE RESET, CONTINUE, RUN, R ETC.

DEFINE CONSTG <
		TRVAR <UFORK,FTW,TMPJFN,SJBUFP>	;;COMMON STORAGE FOR CONTINUE, START COMMANDS
	SETZM TMPJFN		;;INITIALLY NO JFN
   >
;BITS AND FIELDS DEFINED IN OPLIST:

OP%SC==1B0			;SUBROUTINE CALL INSTRUCTION
OP%TRN==1B1			;INSTRUCTION POSSIBLY TRANSFERS TO SOMEWHERE
OP%SKP==1B2			;INSTRUCTION SKIPS
OP%CB==1B3			;CONDITIONAL BRANCH
OP%RET==1B4			;SUBROUTINE RETURN
OP%US==1B5			;UNCONDITIONAL SKIP
OP%NAM==777777B35		;ADDRESS OF ASCIZ NAME OF OPCODE

;FIELDS FOR SYMBOL NAME WORD

SCFLD==17B3			;LEFT FOUR BITS ARE TYPE OF SYMBOL
	SCGLB==4B5		;IF THIS BIT ON, SYMBOL IS GLOBAL
	SCLCL==10B5		;LOCAL
	SCHIDE==40B5		;HIDE THIS SYMBOL FROM PRINTOUT
SNFLD==-1-SCFLD			;REST IS NAME OF SYMBOL
;RESET

.RESET::JRST .RESST		;START OFF THE RESET (IN EXECCA)
.RESS1::CAIE A,"*"		;WANT TO RESET ALL?
	 JRST [	SKIPG A,FORK	;NO - TRY CURRENT
		 ERROR <No program>
		JRST .RESE3]
	MOVX A,FK%KPT!FK%BKG!FK%INT
	MOVSI Q2,-NFRKS		;CLEAR ENTIRE TABLE
	ANDCAM A,FRKTAB(Q2)
	AOBJN Q2,.-1
	SETO A,			;RELEASE ALL HANDLES
	RFRKH			; (GARBAGE COLLECTION)
	 JFCL
RESET0::SKIPG A,FORK		;HAVE CURRENT FORK?
	 JRST RESET2		;NO - CLEAN UP AND EXIT
RESET1:	SKIPN SLFTAB(A)		;YES - IN TABLE?
	 JRST RESET2		;NO - DONE
	HLRZ B,@SLFTAB(A)	;GET HANDLE
	CAIE B,.FHSLF		;IS THIS US
	 JRST [	MOVEI A,0(B)	;NO - KEEP LOOKING
		JRST RESET1]
	MOVX B,FK%INT		;NO LONGER INTERRUPTED
	ANDCAM B,SLFTAB(A)	;CLEAR IT
RESET2:	CALLRET ERESET		;KILL OFF FORK AND RETURN

.RESE2::CALL FRKNM0		;GOBBLE NAME OR SOMETHING
	CONFIRM
.RESE3:	PUSH P,A		;SAVE HANDLE
	CALL PIOFF		;DISABLE INTERRUPTS
	CALL FREL
	POP P,A			;RESTORE HANDLE
	CALL KEFORK		;KILL IT OFF
	CALLRET PION		;TURN THE WORLD BACK ON AND RETURN

;FREL IS USED TO UNMAP FORK PAGES AND SYMBOL TABLE BECAUSE WE WANT TO KILL
;THE FORK.

FREL::	SETO A,
	CALL MAPPF		;UNMAP INFERIOR PAGE, IF ANY.
	 JFCL			;UNMAP SHOULDN'T FAIL
;	CALL PIOFF		;DON'T ALLOW ^C WHILE IN FUNNY STATE
	HRROI A,-1		;UNMAP SYMBOL TABLE WINDOW
	LDB B,[111100,,SYMBF]	;GET PAGE NUMBER OF WINDOW
	HRLI B,.FHSLF		;UNMAP FROM OUR ADDRESS SPACE
	MOVX C,PM%CNT!NSMPGS	;SAY HOW MANY PAGES TO UNMAP
	PMAP
	SETZM SYMOKF		;SAY SYMBOL DATABASE NEEDS INITIALIZATION
;	CALLRET PION		;ALLOW ^C AGAIN AND RETURN
	RET
;SUBROUTINE TO KILL ALL FORKS

ERESET::CALL PIOFF		;TURN OFF INTERRUPTS
	SETOM FORK		;SAY NO CURRENT FORK
	SETOM RUNFK		; OR RUNNING FORK
	CALL FREL		;UNMAP PAGES
	MOVSI Q2,-NFRKS		;DO ALL FORKS
ERESE1: MOVX B,FK%KPT!FK%BKG	;KEPT OR BACKGROUND TEST
	SKIPE CCKEEP		;CHECK INTERRUPTED FORKS ALSO?
	 TXO B,FK%INT		;YES - TEST ^C BIT ALSO
	SKIPE A,FRKTAB(Q2)	;FORK EXISTS
	 TDNE A,B		;YES - TEST FOR KEEPING
	  JRST ERESE2		;DON'T KILL KEPT FORKS
	HLRZ B,@A		;GET HANDLE OF OWNER
	MOVEI A,.FHSLF(Q2)	;FORM FORK HANDLE
	CAIN B,.FHSLF		;DO WE OWN IT?
	 JRST [	CALL KEFORK	;YES - KILL IT
		JRST ERESE2]	;GO ON
	RFRKH			;NO - JUST RELEASE HANDLE
	 ERJMP .+1
	MOVE Q1,FRKTAB(Q2)	;FLAGS
	MOVEI A,.FHSLF(Q2)	;FORK HANDLE
	CALL DELNAM		;DELETE NAME IF ANY
	HRRZ B,FRKTAB(Q2)	;BLOCK ADDRS
	MOVEI A,.FKSZE		;ENTRY SIZE
	MOVEI C,XDICT
	CALL RETMEM		;RETURN STORAGE
	SETZM FRKTAB(Q2)	;CLEAR TABLE ENTRY
ERESE2:	AOBJN Q2,ERESE1		;LOOP
	CALLRET PION		;INTERRUPTS ON AND RETURN

;ROUTINE TO KILL FORK IN A

KEFORK::SKIPN Q1,SLFTAB(A)
	 JRST KEFRK2		;NON-EX FORK
	CALL DELNAM		;REMOVE NAME FROM TABLE
	HLRZ B,0(Q1)		;GET HANDLE OF OWNER
	CAIN B,.FHSLF		;IS IT US?
	 HLLZS @SLFTAB(B)	;YES - CLEAR INFERIOR PNTR
	PUSH P,A		;SAVE HANDLE
	HRRZ A,0(Q1)		;INFERIOR HANDLE
	PUSH P,A		;SAVE IT
	HRRZ B,Q1		;ADDRS OF BLOCK
	MOVEI A,.FKSZE		;SIZE
	MOVEI C,XDICT
	CALL RETMEM		;RETURN STORAGE
	POP P,A			;RESTORE HANDLE OF INFERIOR
	JUMPE A,KEFRK1		;DONE IF AT TOP (NO MORE INFERIORS)
	CALL KEFORK		;RECURSE OVER ALL INFERIORS
KEFRK1:	POP P,A			;RESTORE HANDLE
	SETZM SLFTAB(A)		;CLEAR TABLE ENTRY FOR IT
KEFRK2:	CAIE A,.FHSLF		;THIS US?
	 KFORK			;NOPE - KILL OFF INFERIOR
	  ERCAL [TYPE <%Process disappeared
>
		 RET]		;RETURN NOW
	CAMN A,FORK		;CURRENT FORK
	 SETOM FORK
	CAMN A,RUNFK		;RUNNING FORK
	 SETOM RUNFK
	CAMN A,EDFORK		;EDITOR FORK
	 SETOM EDFORK
	CAMN A,IDFORK		;IDDT FORK
	 SETOM IDFORK
MIC,<
	CAMN A,MICFRK		;MIC HERE
	 SETOM MICFRK
>
	RET
;STEP TO NEXT FORK

NXTFRK:	MOVEI A,NFRKS-1		;LOOK THRU TABLE
NXTFR1:	SKIPN FRKTAB(A)		;EXISTS?
	 JRST NXTFR2		;NO - TRY NEXT
	HLRZ B,@FRKTAB(A)	;GET OWNER
	CAIN B,.FHSLF		;WE OWN IT
	 JRST NXTFR3		;YEP - GOOD ENUF
NXTFR2:	SOJE A,NXTFR5		;STEP TO NEXT
	JRST NXTFR1		;LOOP

NXTFR3:	TRO A,400000		;FORM FORK HANDLE
	MOVEM A,FORK		;SAY THIS THE ONE
	SKIPE B,SLFTAB(A)	;CHECK FOR NAME
	 TXNN B,FK%NAM
	  JRST NXTFR4		;NO NAME - OR UNKNOWN FORK
	HRRO B,.FKNAM(B)	;POINT TO NAME STRING
	ETYPE <[%2M]>
	RET			;RETURN

NXTFR4:	MOVEI B,400000(A)	;FORK NUMBER ONLY
	ETYPE <[Fork %2O]>
	RET			;RETURN

NXTFR5:	SETOB A,FORK		;NO CURRENT FORK
	RET


;ROUTINE TO DELETE A FORK NAME Q1 := FRKTAB ENTRY, A := FORK HANDLE

DELNAM:	STKVAR <SH1,FBA>
	TXNN Q1,FK%NAM		;FORK HAVE NAME?
	 RET			;NO - JUST RETURN
	MOVEM A,SH1		;SAVE HANDLE
	HRRO A,.FKNAM(Q1)	;GET NAME OF FORK
	CALL REMKEP		;IF WAS KEPT, REMOVE FROM KEPT FORK TABLE
	MOVEI A,FRKNMS		;FORK NAME TABLE
	HRRO B,.FKNAM(Q1)	;POINT TO NAME
	TBLUK			;LOOK UP NAME IN TABLE
	TXNN B,TL%EXM		;MATCH?
	 JRST DELNM2		;NOT IN TABLE
	HRRZ B,(A)		;GET ADDRESS OF FORK BLOCK
	SETZRO FKHAN,(B)	;SHOW THAT FORK DOESN'T EXIST ANYMORE
	LOAD C,FKFLAG,(B)	;GET FLAGS
	TXNE C,FN%NAT		;ARE THERE ATTRIBUTES TO THIS NAME?
	JRST DELNM2		;YES, SO DON'T DELETE NAME FROM TABLE
	CALL DELFBK		;DELETE NAME FROM TABLE AND ITS BLOCK
DELNM2:	MOVE A,SH1		;RESTORE HANDLE
	MOVX B,FK%NAM
	ANDCAM B,SLFTAB(A)	;NO LONGER HAS NAME
	RET

;DELFBK removes an entry from the fork name table and releases free space
;taken up by the name and the fork block.
;
;Accepts:	A/	table entry address (such as returned by TBLUK!)

DELFBK:	STKVAR <STA,FBA>
	MOVEM A,STA		;REMEMBER TABLE WORD ADDRESS
	HRRZ B,(A)
	MOVEM B,FBA		;REMEMBER FORK BLOCK ADDRESS
	CALL PIOFF		;DON'T ALLOW ^C WHILE WE RELEASE FREE SPACE
	HLRO A,@STA		;POINT TO NAME BEING DELETED
	CALL REMKEP		;REMOVE KEPT NAME FROM TABLE
	HLRO A,@STA		;POINT TO BUFFERED NAME
	CALL STREM		;RELEASE FREE SPACE TAKEN UP BY NAME
	MOVE B,FBA		;GET ADDRESS OF FORK BLOCK IN FREE SPACE
	MOVEI A,FKTLEN		;SAY HOW MANY WORDS IN FORK BLOCK
	CALL RETBUF		;GET RID OF OLD FORK BLOCK
	MOVE B,STA		;POINT TO ENTRY
	MOVEI A,FRKNMS		; TABLE
	TBDEL			;REMOVE NAME
	CALLRET PION		;ALLOW ^C NOW THAT TABLE CONSISTENT AGAIN

;REMKEP removes a kept fork name from the kept fork table.
;
;Accepts:	A/	pointer to name

REMKEP:	MOVE B,A		;POINTER TO NAME IN B
	MOVEI A,KEPNMS		;IS THIS IN TABLE OF KEPT FORKS?
	TBLUK
	TXNN B,TL%EXM
	RET
	MOVE B,A		;YES, SO DELETE IT FROM TABLE
	MOVEI A,KEPNMS
	TBDEL
	RET

;ROUTINE TO ADD NEW FORK NAME TO TABLE
;CALLED WITH FORK HANDLE IN A
;	AND POINTER TO ASCIZ FORK NAME IN B

ADDNAM::STKVAR <AFORK,ENPTR,AUGMNT,NAMPTR>
	MOVEM A,AFORK		;SAVE HANDLE
	MOVE A,CSBUFP		;WRITE NAME INTO SOME SCRATCH SPACE
	MOVEI C,.CHNUL		;STOP ON NULL
	SOUT			;...
	MOVEM A,ENPTR		;REMEMBER END OF BASIC NAME
	MOVE A,AFORK		;GET FORK HANDLE
	MOVX B,FK%NAM		;FORK NOW HAS NAME
	IORM B,SLFTAB(A)
	SETOM AUGMNT		;START WITH 0 AS AUGMENT TO NAME
ADDNM2:	MOVEI A,FRKNMS		;POINT TO TABLE
	MOVE B,CSBUFP		;POINT TO NAME
	TBLUK			;CHECK EXISTS ALREADY
	TXNN B,TL%EXM		;EXACT MATCH?
	 JRST ADDNM3		;NO - OK
	HRRZ C,(A)		;GET ADDRESS OF FORK BLOCK
	LOAD B,FKHAN,(C)	;SEE IF A FORK IS IN THIS SLOT YET
	JUMPE B,ADDNM4		;NO, SO USE IT
	AOS B,AUGMNT		;STEP TO NEXT AUGMENT
	MOVE A,ENPTR		;GET END OF DUPLICATE NAME
	MOVEI C,5+5		;INCREMENT NAMES IN DECIMAL
	NOUT			;FORM NEW NAME
	 CALL JERR		;SHOULDN'T FAIL!
	JRST ADDNM2		;GO SEE IF THIS MODIFIED NAME IN TABLE

;Come here when the name is found in the table but no real fork is currently
;associated with the name.

ADDNM4:	MOVE B,AFORK		;NO, SO USE THIS SLOT
	STOR B,FKHAN,(C)
	HLRZ B,(A)		;GET ADDRESS OF PROGRAM NAME
	MOVEM B,.FKNAM(Q1)	;REMEMBER NAME OF THIS PROGRAM
ADDNM5:	MOVE A,AFORK		;GET HANDLE OF FORK THAT MAY NEED KEEPING
	LOAD D,FKFLAG,(C)	;GET FLAGS ABOUT THIS NAME
	MOVE B,SLFTAB(A)	;SEE IF FORK IS ALREADY KEPT
	TXNN B,FK%KPT		;IF SO, CALL ANNKEP TO PUT NAME IN KEPNMS
	TXNE D,FN%KEP		;ARE WE SUPPOSED TO KEEP THIS GUY?
	CALL ANNKEP		;YES, DO IT
	MOVE B,CSBUFP		;WE NOW HAVE UNIQUE NAME, ANNOUNCE NEW NAME
	SKIPL AUGMNT		;DON'T ANNOUNCE NAME UNLESS WE CHANGED IT
	ETYPE <[%2M]%_>		;PRINT NAME
	RET			;RETURN

;Come here when the name is a brand new name, either because it was, or
;because we just made it one.

ADDNM3:	CALL PIOFF		;DON'T ALLOW ^C UNTIL FREE SPACE ADDRESS STORED
	MOVE A,CSBUFP		;POINT TO NAME
	CALL XBUFFS		;BUFFER IT IN PERMANENT SPACE
	HRRZM A,NAMPTR		;REMEMBER ADDRESS OF NAME
	HRRZM A,.FKNAM(Q1)	;STORE ADDRESS OF NAME
	CALL GETFBK		;GET FORK BLOCK
	HRRZ B,A		;REMEMBER ADDRESS OF BLOCK
	MOVE C,A		;GET ADDRESS OF FORK BLOCK FOR ADDNM5
	MOVE A,AFORK		;GET FORK HANDLE
	STOR A,FKHAN,(B)	;STORE IN BLOCK
	HRL B,NAMPTR		;STRING PNTR
	MOVEI A,FRKNMS		;NAME TABLE
	TBADD			;PUT INTO TABLE
	CALL PION		;ALLOW ^C NOW THAT FREE SPACE ADDRESS SAFELY IN TABLE
	JRST ADDNM5

;GETFBK gets a fork block.
;Call PIOFF before this routine, so that user can't type ^C between the
;time this routine assigns free space, and the time you store the address of
;the block somewhere!
;
;Returns+1:	A/	address of zeroed block in permanent free space

GETFBK:	CALL GETFB1		;DO MOST OF THE WORK
	HRL B,FRKDEF		;GET ADDRESS OF DEFAULT BLOCK
	HRR B,A			;PREPARE TO INITIALIZE NEW BLOCK WITH DEFAULTS
	BLT B,FKTLEN-1(A)	;COPY DEFAULTS INTO REAL BLOCK
	RET

;GETFB1 is only called for a fork block when defaults must be circumvented.
;Usually, please call GETFBK.

GETFB1::MOVEI A,FKTLEN		;SAY HOW MANY WORDS WE NEED FOR FORK BLOCK
	CALL GTBUFX		;ASSIGN SPACE IN PERMANENT FREE SPACE
	HRL C,A			;PREPARE TO ZERO THE BLOCK
	HRRI C,1(A)
	SETZM (A)		;CLEAR FIRST WORD
	BLT C,FKTLEN-1(A)	;CLEAR REST
	RET

;ANNKEP causes a fork to be kept and announces that it is doing so.
;
;Accepts:	A/	fork handle

ANNKEP::MOVE C,SLFTAB(A)	;GET OLD SETTING
	SKIPE B,.FKNAM(C)	;GET NAME OF FORK BEING KEPT OR 0 AND POINTER TO NULL STRING
	HRRO B,B		;THERE IS A NAME, MAKE ASCIZ POINTER
	TXON C,FK%KPT		;KEEP FORK AND ANNOUNCE IF THIS IS NEWS
	ETYPE <[Keeping %2M]
>
	MOVEM C,SLFTAB(A)
	JUMPE B,R		;DON'T ATTEMPT TO ADD NULL NAME TO TABLE
	HRLZ B,B		;YES, MAKE TABLE ENTRY
	MOVEI A,KEPNMS		;ADD THIS FORK TO LIST OF KEPT FORKS
	TBADD			;ADD NAME TO LIST OF KEPT FORKS
	 ERJMP [CALL DGETER	;FAILED, MAKE SURE WE UNDERSTAND WHY
		CAIE A,TADDX2	;NAME ALREADY THERE?
		CALL JERR	;NO, UNEXPECTED ERROR
		RET]		;YES, SO DON'T WORRY
	RET

;ROUTINE TO SET FORK NAME , A := FORK HANDLE, B := JFN

SFKNAM::TRVAR <<SFKBUF,EXTSIZ>,SFKFRK,SFKJFN>
	MOVEM A,SFKFRK		;SAVE HANDLE
	MOVEM B,SFKJFN		; AND JFN
	HRRZ Q1,SLFTAB(A)	;POINTER
	MOVEI Q1,.FKPTM(Q1)	;POINT TO PTTYMD BLOCK FOR FORK
	MOVE A,B		;JFN TO A
	CALL SUBNAM		;GET NAME
	HRROI A,SFKBUF		;POINTER TO NAME
	MOVE B,SFKJFN		;RECOVER JFN
	MOVX C,1B8		;FILE NAME
	JFNS
	MOVE A,SFKFRK		;GET FORK HANDLE
	MOVE Q1,SLFTAB(A)	;TABLE ENTRY
	CALL DELNAM		;REMOVE ANY EXISTING NAME
	LDB C,[POINT 7,SFKBUF,6] ;GET FIRST CHAR
	JUMPE C,R		;NULL - EXIT
	HRROI B,SFKBUF
	JRST ADDNAM		;GO ADD NAME
;REENTER
;DECODE AND CHECK SUBROUTINE ALSO USED BY REDIRECT/DETACH

$REENT::SKIPGE A,FORK
	ERROR <No program>
	CALL GETENT		;GET ENTRY VECTOR
	CAIGE B,2		;LONG ENOUGH TO HAVE REENTER?
	ERROR <No REENTER address>
	RET

;REENTER COMMAND DISPATCHES HERE

.REENT::NOISE <PROGRAM>
	CONFIRM
REENT1:	SETZM STAYF		;DON'T STAY AT COMMAND LEVEL (UNTIL "REENTER STAY" IMPLEMENTED!)
	CALL $REENT

;REDIRET/DETACH...(AND) REENTER  JOINS HERE

..REEN::MOVNI B,2		;REENTER CODE FOR PA1050
	CALL NOPAT		;SKIP IF NO PA1050
	 JRST ..STCR		;PA1050, GO FINISH SETTING UP
	MOVEI B,1		;ENTRY VECTOR INDEX 1 FOR REENTER
	JRST ..STCR		;CONTINUE BELOW AND START PROCESS
;CONTINUE
;RESUMES FROZEN INFERIOR FORKS

;"CONTINUE" COMMAND DISPATCHES TO HERE

.CONTI::CALL .CONT1		;PARSE COMMAND
	CALL $CONTI		;SET FORK
	JRST ..CONT		;RESUME PROCESS

.CONT1:	NOISE <FORK>
	CONSTG			;ALLOCATE STORAGE
	SETZM STAYF
	MOVE A,FORK		;CONTINUE CURRENT FORK UNLESS OTHERWISE SPECIFIED
	MOVEM A,UFORK		;USE UFORK UNTIL CR SEEN FOR CONFIRMATION
.CONT2:	MOVEI B,$CONFD		;APPROPRIATE FIELD DESCRIPTORS
	TLOE Z,F1		;FIRST TIME THRU?
	MOVEI B,$CONF1		;NO - ONLY ALLOW COMMA OR CR
	CALL FLDSKP		;PARSE LINE
	 CMERRX
	LOAD D,CM%FNC,.CMFNP(C)	;GET FUNCTION CODE
	CAIN D,.CMCFM		;CR?
	 JRST CONU		;YES - CHECK MODES
	CAIN D,.CMCMA		;COMMA SEEN?
	 JRST .CONT3		;YES - CHECK SUBCOMMANDS
	CAIN D,.CMKEY		;KEYWORD?
	JRST [	MOVE D,.CMDAT(C) ;YES - SEE WHICH ONE
		CAIN D,$CMODE	;MODE KEYWORD?
		JRST CONC1	;YES
		LOAD D,CM%FNC,.CMFNP(C) ;NO, MUST BE FORK. RESTORE D
		JRST .+1]
	CALL FRKNM0		;PARSE NAME OR NUMBER
	MOVEM A,UFORK		;SAVE HANDLE (DON'T TOUCH "FORK" CELL UNTIL CONFIRMATION!)
	JRST .CONT2		;LOOK FOR CR OR COMMA

.CONT3:	CRRX <Carriage return to enter subcommands>
	 JRST .CONT4
	SUBCOM $PMODE		;GET PROGRAM MODES
CONU:	MOVE A,UFORK		;ONLY CHANGE "FORK" NOW THAT COMMAND IS CONFIRMED
	MOVEM A,FORK
	MOVX B,FK%RUN
	TDNE B,SLFTAB(A)	;RAN THIS ONE?
	MOVEM A,RUNFK		;YES - STORE IN RUNFK
	JRST .CONT5

.CONT4:	KEYWD $PMODE		;LOOK UP A MODE IF NO CR GIVEN
	 0			;NO DEFAULT
	 CMERRX
	CALL 0(P3)		;DISPATCH
.CONT5:	SKIPG A,FORK		;DO WE HAVE A FORK
	 ERROR <No program>
	SKIPE Q1,TMPJFN		;SUBCOMMANDS RETURN HERE
	 JRST .CONT6		;DON'T FIDDLE PRIMARY JFNS
	SKIPE B,SLFTAB(A)	;KNOWN FORK
	 TXNN B,FK%BKG!FK%TTY	;BACKGROUND OR TTY WAITER
	  JRST .CONT7		;NO FORK, OR NOT BACKGROUND
	MOVX B,FK%BKG
	ANDCAM B,SLFTAB(A)	;CLEAR BACKGROUND FLAG
.CONT6:	MOVEI A,.FHSLF		;SEE WHAT WE HAVE FOR JFNS
	GPJFN
	MOVE A,FORK		;GET FORK HANDLE BACK
	MOVE D,SLFTAB(A)	;GET ITS FLAGS
	TLNE Q1,-1		;WANT TO CHANGE PRIMARY INPUT?
	 TXOA D,FK%PRI		;YES - SET FLAG
	  HLL Q1,B		;NO - GET PRIMARY INPUT JFN
	TRNE Q1,-1		;WANT PRIMARY OUTPUT?
	 TXOA D,FK%PRO		;YES - SET FLAG
	  HRR Q1,B		;NO - SET PRIMARY OUTPUT JFN
	MOVEM D,SLFTAB(A)	;UPDATE FLAGS
	MOVE B,Q1		;JFNS TO B
	MOVE A,FORK		;FORK TO A
	SPJFN			;SET PRIMARY JFNS
.CONT7:	SKIPN SLFTAB(A)		;KNOW THIS FORK?
	RET			;NO - DONE
	MOVX B,FK%INT
	ANDCAM B,SLFTAB(A)	;CLEAR INTERRUPTED BIT
	RET			;RETURN

;SUBCOMMAND TABLE AND ROUTINES

$PMODE:	TABLE
	T BACKGROUND
	T INPUT,,.CINPU
	T NO,,.CNO
	T OUTPUT,,.COUTP
	T QUIET,,.CQUIE
	T SIGNAL,,.CSIGN
	T STAY
	TEND

;HANDLE "STAY" OR "NORMALLY" AS KEYWORD ON CONTINUE LINE

CONC1:	CONFIRM
	HRRZ C,0(B)		;GET ROUTINE ADDRESS
	HRRZ C,0(C)
	CALL 0(C)		;DO IT
	JRST CONU		;FINISH UP

$CMODE::TABLE
	T NORMALLY,,..NORM
	T STAY,,..STAY
	TEND

..NORM:	SETZM STAYF		;I.E. NO STAY
	RET
;REDIRECT OUTPUT TO FILE

.COUTP:	NOISE <TO FILE>
	SETZ A,
	CALL COUTFN		;GET OUTPUT FILE NAME
	 JRST CERR
	CONFIRM
	MOVX B,OF%WR		;OPEN FOR WRITE
	CALL $OPEN7
	JRST .CSIGO		;STORE JFN AND RETURN

;GET INPUT FROM FILE

.CINPU:	NOISE <FROM FILE>
;**;[978] Replace 1 line @.CINPU+1 line   JMP  Sep 27 83 
	MOVEI B,(GJ%OLD!GJ%MSG)	;[978] GTJFN BITS
	SETZ A,
	CALL SPECFN		;COLLECT AN INPUT FILE
	 JRST CERR
	CONFIRM
	MOVX B,OF%RD		;OPEN FOR READ
	JRST .CSIGI		;STORE JFN AND RETURN

;"QUIET" - OUTPUT TO NUL:

.CQUIE:	CONFIRM
	MOVEI A,.NULIO		;SET NULL JFN
	HRRM A,TMPJFN		;FOR OUTPUT
	JRST .CBAC2		;SET INPUT JFN FOR TRAP


;STAY AT COMMAND LEVEL

.STAY:	CONFIRM
	JRST ..STAY

;SIGNAL TTY I/O

.CSIGN:	NOISE <WHEN TTY WANTED FOR>
	SKIPA A,[677777]	;CAUSE PRIMARY TRAP
.CNO:	MOVEI A,.NULIO		;NULL DEVICE
.CSIG2:	KEYWD $CSIGN
	 T EITHER,,.CSIGB	;DEFAULT TO EITHER
	 JRST CERR
	CONFIRM
	JRST 0(P3)		;DISPATCH

$CSIGN:	TABLE
	T EITHER,,.CSIGB	;SIGNAL BOTH
	T INPUT,,.CSIGI		;SIGNAL INPUT
	T OUTPUT,,.CSIGO	;SIGNAL OUTPUT
	TEND

.CSIGB:	CALL .CSIGI		;SET INPUT
.CSIGO:	HRRM A,TMPJFN		;SET OUTPUT JFN
	JRST ..STAY		;RETURN

;SET BACKGROUND MODE

.BACKG:	CONFIRM
;**;[950] Change 1 [908] line at CBAC2:	PED	16-FEB-83
.CBAC2:	MOVEI A,677777		;[908] [950] SET FOR INPUT TRAP
.CSIGI:	HRLM A,TMPJFN		;SET PRIMARY INPUT
..STAY:	SETOM STAYF		;STAY AT COMMAND LEVEL
	RET			;EXIT

DEFINE PRSTG			;LOCAL STORAGE FOR "SET PROGRAM"
<	TRVAR <DEFF,IINFO,STRA,PNM>
>

;SET DEFAULT PROGRAM attribute
;
;assigns default attributes, used in lieu of SET FILE attributes, if no
;SET PROGRAM overrides it.

SDPROG::PRSTG			;GET LOCAL STORAGE
	SETOM DEFF		;SAY WE'RE DOING DEFAULTS
	JRST PROG1		;USE SAME CODE AS "SET PROGRAM"

;SET NO DEFAULTS (FOR) PROGRAM

SNDPRG::PRSTG			;GET LOCAL STORAGE
	SETOM DEFF		;SAY THIS IS DEFAULT
SNPRG1:	CALL PBLK		;POINT AT BLOCK
	SETZRO FKFLAG,(A)	;CLEAR DEFAULTS
	RET

;SET PROGRAM NAME ATTRIBUTE
;ASSIGNS ATTRIBUTES TO FORKS OF THE SPECIFIED NAME

PROG::	PRSTG			;GET LOCAL STORAGE
	SETZM DEFF		;SAY NOT SETTING DEFAULTS
	NOISE (NAME)
	WORDX <Fork name>
	 CMERRX <Invalid fork name>
	CALL BUFFF		;BUFFER THE NAME
	MOVEM A,PNM		;REMEMBER IT
PROG1:	NOISE (ATTRIBUTE)
	KEYWD PROGA		;READ ATTRIBUTE
	 0			;NO DEFAULT
	 CMERRX			;STANDARD ERROR IF BAD KEYWORD TYPED
	CALLRET (P3)		;EXIT THROUGH SPECIFIED PLACE

PROGA:	TABLE			;TABLE OF ATTRIBUTES
	T EPHEMERAL,ONEWRD,PEPH	;SET PROGRAM NAME EPHEMERAL
	T KEEP,,PKEEP		;SET PROGRAM NAME KEEP (AND)...
	T NO-EPHEMERAL,,PNEPH	;SET PROG NAME NO-EPHEMERAL
	T NONE,ONEWRD,PNONE	;UNDO ANY PREVIOUS SET PROGRAM
	TEND

PNEPH:	CONFIRM
	CALL PBLK		;MAKE SURE THIS PROGRAM HAS A BLOCK
	TXZ B,FN%EPH!FN%KEP	;DON'T BE CONTRADICTORY
	TXO B,FN%NEF		;SAY NO EPHEMERAL
	STOR B,FKFLAG,(A)	;STORE UPDATED FLAGS
	RET

PEPH:	CALL PBLK		;FIND PROGRAM BLOCK
	TXZ B,FN%KEP!FN%NEF	;AVOID CONTRADICTION
	TXO B,FN%EPH		;SAY THIS FORK SHOULD BE EPHEMERAL
	STOR B,FKFLAG,(A)	;STORE UPDATED FLAGS
	RET			;DONE

PNONE:	SKIPE DEFF		;CLEARING DEFAULTS?
	JRST SNPRG1		;YES, SAME AS "SET NO DEFAULTS PROG"
	MOVEI A,FRKNMS
	MOVE B,PNM		;POINTER TO PROGRAM NAME
	TBLUK			;SEE IF NAME IN TABLE
	TXNN B,TL%EXM		;WAS IT IN TABLE?
	RET			;NO, SO NOTHING TO DO
	HRRZ B,(A)		;YES, GET POINTER TO FORK BLOCK
	JE FKHAN,(B),DELFBK	;IF IN TABLE AND NO REAL FORK, THROW NAME AWAY
	SETZRO FKFLAG,(B)	;CLEAR ALL ATTRIBUTES
	RET

PROGK:	TABLE
	T CONTINUE,,[EXP ..CONT,[ASCIZ /Continuing/]]
	T REENTER,,[EXP REENT1,[ASCIZ /Reentering/]]
	T START,,[SAD:	EXP .STRT1,[STMES: ASCIZ /Starting/]]
	TEND

;SET PROGRAM NAME KEEP (AND) ACTION (WHEN INVOKED AS A COMMAND)

PKEEP:	NOISE (AND)
	HELPX <how to restart program when it is invoked as a command,>
	KEYWD PROGK
	 0
	CMERRX
	HLRO A,(B)		;GET POINTER TO KEYWORD STRING
	MOVEM A,IINFO		;SAVE FOR "INFO PROG" COMMAND
	NOISE (WHEN INVOKED AS A COMMAND)
	CONFIRM
	CALL PBLK		;GET NAME BLOCK FOR SPECIFIED FORK
	TXO B,FN%KEP		;SAY TO KEEP FORK
	TXZ B,FN%EPH!FN%NEF	;AVOID CONTRADICTIONS
	STOR B,FKFLAG,(A)	;STORE UPDATED FLAGS
	MOVE B,IINFO		;GET POINTER TO KEYWORD
	STOR B,FKRESP,(A)	;REMEMBER FOR "INFO PROG" COMMAND
	MOVE B,0(P3)		;GET ADDRESS FOR RESTARTING FORK AT
	STOR B,FKRADD,(A)	;REMEMBER IT
	MOVE B,1(P3)		;GET POINTER TO NOTIFICATION STRING
	HRLI B,-1		;MAKE BYTE POINTER
	STOR B,FKRMES,(A)	;REMEMBER POINTER TO RESTART MESSAGE
	HLRZ B,(A)		;GET ADDRESS OF NAME FOR ANNKEP
	LOAD A,FKHAN,(A)	;GET FORK HANDLE
	JUMPE A,R		;IF FORK DOES NOT EXIST JUST RETURN
	CALLRET ANNKEP		;ELSE KEEP IT AND RETURN

;PBLK is a local routine used by SET PROGRAM to point at the fork block for
;the fork specified in the command, making a new block first if necessary.
;
;Returns+1:	A/	Address of fork block (see EXECDE for description)
;		B/	flag word (FKFLAG) with FN%NAT on

PBLK:	SKIPE DEFF		;DOING "SET PROGRAM DEFAULT"?
	JRST [	MOVE A,FRKDEF	;YES, GET ADDRESS OF DEFAULT BLOCK
		LOAD B,FKFLAGS,(A) ;GET DEFAULT FLAGS
		RET]
	MOVE B,PNM		;GET POINTER TO PROGRAM NAME
	MOVEI A,FRKNMS		;POINT TO THE NAME TABLE
	TBLUK			;IS NAME ALREADY IN TABLE?
	TXNN B,TL%EXM
	JRST [	CALL PIOFF	;NO, TURN OFF ^C WHILE WE FIX TABLE
		MOVE A,PNM	;GET POINTER TO NAME
		CALL XBUFFS	;PUT STRING IN PERMANENT SPACE
		MOVEM A,STRA	;REMEMBER ADDRESS
		CALL GETFBK	;GET FORK BLOCK
		HRL A,STRA	;COMBINE WITH POINTER TO NAME
		MOVE B,A	;TABLE ENTRY INTO B
		MOVEI A,FRKNMS
		TBADD		;ADD NEW ENTRY TO TABLE
		CALL PION	;ALLOW ^C NOW THAT TABLE IS CONSISTENT
		JRST .+1]	;NOW A HAS ADDRESS OF ENTRY
	HRRZ A,(A)		;GET ADDRESS OF FORK BLOCK
	LOAD B,FKFLAG,(A)	;GET FLAG WORD
	TXO B,FN%NAT		;SAY NAME HAS ATTRIBUTE
	RET

;DECODE AND CHECK SUBROUTINE ALSO USED BY REDIRECT/DETACH

$CONTI::SKIPGE A,FORK		;HANDLE OF AN INFERIOR FORK
	ERROR <No program>	;NO INFERIORS AT ALL
	MOVEM A,RUNFK		;SAVE AS FORK BEING RUN
	RFSTS			;GET ITS STATUS (HANDLE IN A)
	TLNE A,077700		;DISTINGUISH -1 FROM 0-5,400000-400005
	ERROR <Program disappeared> ;-1 = UNASSIGNED HANDLE.
	RET
;COMMON ROUTINE TO START / RESTART AND EXISTING FORK
; ENTER WITH C(B) := FRKNMS ENTRY

RSTFK::	CONSTG			;ALLOCATE STORAGE
	HRRZ B,(B)		;GET FORK TABLE ADDRESS
	MOVEM B,FTW		;REMEMBER FORK BLOCK ADDRESS
	LOAD A,FKHAN,(B)	;GET FORK HANDLE FROM TABLE
	MOVEM A,FORK		;SET TO CURRENT FORK
	SETZM STAYF
	CALL .CONT5		;COMMON SETUP
	MOVEM A,RUNFK		;SET AS CURRENT RUNNING FORK
	MOVX B,FK%RUN
	MOVE C,FTW
	JE FN%KEP,(C),CONTF1	;IF FORK NOT DECLARED KEPT THEN JUST START IT
	TDNN B,SLFTAB(A)	;HAS THIS GUY BEEN RUN BEFORE?
	 JRST CONTF1		;NO - START IT THEN
	MOVE B,FTW		;GET TABLE WORD AGAIN
	LOAD A,FKRMES,(B)	;GET POINTER TO MESSAGE
DOMES:	ETYPE [%1M]%_		;PRINT APPROPRIATE RESTART MESSAGE
	LOAD A,FKRADD,(B)	;SEE WHERE TO GO TO RESTART FORK
	JRST @A			;DO CORRECT RESTART FOR THIS FORK

CONTF1:	HRROI A,STMES		;GET CORRECT MESSAGE
	XCT DOMES		;PRINT MESSAGE IN STANDARD MANNER
	JRST @SAD		;START IT UP
;"REDIRECT/DETACH ... (AND) CONTINUE" JOINS HERE

..CONT::MOVE A,RUNFK		;LAST RUN FORK
	TXO A,SF%CON		;SET "CONTINUE" BIT
	SFORK			;CONTINUE PROCESS FROM HALT
	 ERCAL CJERRE		;FAILED, TELL USER WHY (PROBABLY NEVER STARTED!)

;WHEN THE PROGRAM IS RUNNING WE DON'T WANT THE EXEC TO HAVE ANY
;OF ITS PAGES MAPPED. HENCE CLEAR THE PAGE BUFFER:

	CALL SETGO		;SET UP FOR PROGRAM RUNNING
	CALL PIOFF		;DON'T ALLOW ^C WHILE IN FUNNY STATE
	CALL FREL		;RUNNING FORK MAY CHANGE SYMBOL TABLE, SO CLEAR DATABASE
	CALL PION		; HANDLE AGAIN; ALLOW ^C
	MOVE A,RUNFK
	JRST WAITR		;GO RESUME FORK AND WAIT FOR IT
;"DDT" COMMAND. LOAD DDT IN INFERIOR FORK IF NECESSARY,
;TRANSMIT SYMBOL TABLE POINTER, START DDT.

.DDT::	TRVAR <DDTSEC,JBSYM,JBBUSY,SA,PRGSEC>
	CALL GSWIS		;PARSE POSSIBLE SWITCHES
	JUMPL A,[SKIPG B,FORK	;IF NO SPECIAL SECTION, IS THERE A FORK?
		 JRST .+1	;NO FORK AND NO SPECIAL SECTION, LEAVE AS -1.
		 HRRZ C,SLFTAB(B) ;NO SPECIAL SECTION BUT THERE IS A FORK
		 MOVE A,CODSEC(C) ;USE CODE SECTION FOR DDT'S
		 JRST .+1]
	MOVEM A,DDTSEC		;SAVE SECTION TO PUT DDT IN
	SETZM STAYF
	SETZM JBSYM
	SETZM JBBUSY		;CLEAR SYMBOL DATA
	SKIPLE A,FORK		;CURRENT FORK?
	 SKIPN A,SLFTAB(A)	;YES - KNOWN?
	  JRST DDT2		;NO FORK - JUST GET DDT
	TXNE A,FK%DDT		;DDT PRESENT IN THIS FORK?
	 JRST DDT4		;YES - JUST START IT
	SETZM PRGSEC		;FIRST ASSUME NO PROGRAM SECTION SPECIFIED
	SKIPL A,CODSEC(A)	;IS THERE ONE?
	MOVEM A,PRGSEC		;YES, REMEMBER IT

;THERE IS A FORK, SEE IF IT ALREADY CONTAINS SOMETHING THAT LOOKS
;LIKE A DDT.  IF SO, LEAVE IT, AS IT MAY CONTAIN BREAKPOINTS,
;MODIFIED SYM TAB PTR, ETC.

	MOVEI A,DDTORG		;DDT BEGINNING ADDRESS
	HRL A,PRGSEC		;LOOK IN CORRECT SECTION
	CALL MAPPF
	 JRST CJERRE		;FAILED-- TYPE JSYS ERROR
	TXNN B,PA%PEX		;PAGE EXISTS?
	JRST DDT1		;NO, FORK DOESN'T HAVE DDT
	ANDI A,777		;LINE ONLY
	MOVE A,PAGEN(A)		;LOAD FIRST WORD
	CAMN A,[JRST DDTORG+2]
	JRST DDT3		;ALREADY HAVE ACCEPTABLE DDT

;FORK DOESN'T HAVE UDDT - SEE IF THERE'S SOME OTHER DEBUGGER
;OR IF NOT THEN SEE IF THERE IS A SYMBOL TABLE PNTR

DDT1:	MOVEI A,JOBDDT		;LOC FOR DEBUGGER ADDRS
	HRL A,PRGSEC		;USE APPROPRIATE SECTION
	CALL MAPPF		;MAP PAGE OF FORK
	 JRST CJERRE		;FAILED-- TYPE JSYS ERROR
	TXNE B,PA%PEX		;NO PAGE?
	TXNN B,PA%RD		;READ PROTECT?
	JRST DDT2		;NO USEABLE PTR
	HRRZ A,PAGEN(A)		;SEE IF ALREADY HAVE START ADDRS
	JUMPG A,[MOVEM A,SA	;YES, SAVE IT
		 JRST DDT5]	;AND JOIN COMMON CODE
	MOVEI A,JOBSYM&777	;PNTR TO SYMBOL TABLE
	MOVE C,PAGEN(A)		;FETCH SYM TAB PTR WORD
				;IF NEGATIVE, IT WILL BE ASSUMED TO BE PTR
	MOVE D,PAGEN+1(A)	;.JBUSY IS JOBSYM+1
				;NO CHECKING NEEDED,  DDT WILL FIX IT UP.
	MOVEM C,JBSYM		;REMEMBER SYMBOL POINTER
	MOVEM D,JBBUSY		;REMEMBER OTHER WORD (WHAT IS IT?)
DDT2:	SKIPGE JBSYM		;SYMBOL TABLE POINTER?
	JRST DDT6		;YES, GO USE UDDT
	SKIPGE A,FORK		;GET HANDLE ON CURRENT FORK
	JRST SDDT		;NONE, SO USE SDDT
	GCVEC			;IS PA1050 PRESENT?
	JUMPG B,DDT6		;PA1050 PRESENT--USE UDDT
SDDT:	SKIPA B,[POINT 7,[GETSAVE(SYS:SDDT.)]] ;DDT WITH SYMBOLS
DDT6:	MOVE B,[POINT 7,[GETSAVE(SYS:UDDT.)]]
;DDT...

;LOAD SELECTED DDT

	MOVSI A,(GJ%OLD!GJ%SHT)	;SET UP FOR OLD-FILE AND SHORT FORM GTJFN
	CALL GTJFS		;GET AND STACK THE JFN
	 CALL CJERRE		;IF FAILS, JUST PRINT ERROR
	MOVE B,DDTSEC		;PASS -1 OR SECTION TO MERGE ROUTINE
	CALL $MERGE		;MERGE IT INTO FORK, CREATING FORK IF NONE,
				;AND RELEASE JFN

;STORE SYMBOL TABLE POINTER

	SKIPL JBSYM		;SYMBOL POINTER?
	JRST DDT3		;NO
	MOVEI A,DDTSYM
	SKIPL DDTSEC		;USE SPECIAL SECTION IF GIVEN
	HRL A,DDTSEC
	HLL Q1,A		;REMEMBER SECTION
	CALL MAPPF
	 JRST CJERRE		;FAILED-- TYPE JSYS ERROR
	ANDI A,777
	HRR Q1,PAGEN+1(A)	;WHERE TO STORE UNDEF PTR
	HRRZ A,PAGEN(A)		;POINTER TO WHERE TO PUT POINTER
	SKIPL DDTSEC		;USE DDT SECTION IF SPECIAL
	HLL A,Q1		;SAY WHICH SECTION TO LOOK IN
	CALL MAPPF
	 JRST CJERRE		;FAILED-- TYPE JSYS ERROR
	ANDI A,777
	MOVE C,JBSYM
	MOVEM C,PAGEN(A)	;STORE POINTER
	MOVE A,Q1		;WHERE TO PUT UNDEF PTR IN DDT
	CALL MAPPF
	 JRST CJERRE		;FAILED-- TYPE JSYS ERROR
	ANDI A,777
	MOVE D,JBBUSY
	MOVEM D,PAGEN(A)	;STORE OTHER WORD (WHAT IS IT?)
DDT3:	SKIPLE A,FORK		;HAVE FORK?
	 SKIPN B,SLFTAB(A)
	  JRST DDT4		;NOPE - JUST START
	MOVX B,FK%DDT		;YES - MARK DDT PRESENT
	IORM B,SLFTAB(A)
	HRRZ A,SLFTAB(A)	;GET ADDRESS OF FORK DATA
	MOVEI B,DDTORG		;GET START ADDRESS OF DDT
	SKIPL DDTSEC
	HRL B,DDTSEC		;GIVE IT CORRECT SECTION
	MOVEM B,DDTSA(A)	;REMEMBER DDT'S START ADDRESS

;TRANSFER CONTROL TO DDT

DDT4:	MOVE A,FORK		;GET FORK BEING STARTED
	HRRZ A,SLFTAB(A)	;GET ADDRESS OF FORK DATA
	MOVE A,DDTSA(A)		;GET DDT'S START ADDRESS FOR THIS FORK
	MOVEM A,SA		;REMEMBER START ADDRESS
DDT5:	MOVNI B,3		;CODE FOR PA1050 IF ANY
	CALL NOPAT		;PA1050 RUNNING IN FORK?
	 JRST GOTO2		;YES
	MOVE B,SA		;NO PA1050, GET START ADDRESS
	JRST GOTO2		;JOIN "GOTO" COMMAND: UNMAP PAGE, START FORK.
;FORK <NAME> OR <NUMBER>
;SETS FORK ACCESSED BY START, REENTER, GOTO, /, \, TEN50 DDT, SAVE.

.FORK::	NOISE (IS)
	CALL FRKNMC		;GET NAME, NUMBER ETC.
	MOVEM A,FORK		;STORE AS CURRENT FORK
	SETZM SYMOKF		;FORCE SYMBOLS TO BE RECOMPUTED
	JRST CMDIN4		;DONE

;SUBROUTINE TO ASK FOR FORK NUMBER OR NAME
;RETURNS A/ FORK HANDLE

FRKNMC:	TLOA Z,F1		;EXITS THRU NXTFRK
FRKNAM:	TLZ Z,F1		;GUARANTEE CURRENT FORK EXISTS
	MOVEI B,$FRKNM
	HRRZ A,FRKNMS		;GET NUMBER OF FORK NAMES
	SKIPN A			;NONE?
	 HRRZ B,.CMFNP(B)	;YUP, SKIP FORKS, START WITH #
	CALL FLDSKP		;PARSE FIELD
	 CMERRX
	LDB D,[POINT 9,.CMFNP(C),8] ;SEE WHAT WE GOT
	CAIN D,.CMCFM		;JUST TYPED CR?
	 JRST FRKNM2		;YES - GET HIM A FORK
	CALL FRKNM0		;CHECK FURTHER ARG
	CALLRET CONF		;FORCE CONFIRM AND RETURN HANDLE

FRKNM2:	TLNE Z,F1		;WANT TO FIND ONE?
	 JRST NXTFRK		;YES - LOOK IN TABLE
	SKIPG A,FORK		;NO - HAVE A CURRENT FORK
	 ERROR <No current fork>
	RET			;RETURN

;PARSED NAME OR NUMBER - CHECK VALIDITY

FRKNM0:	STKVAR <TMPSTR>
	CAIN D,.CMKEY		;NAME?
	 JRST [	HRRZ C,(B)	;YES, GET ADDRESS OF FORK BLOCK
		HLRO A,(B)	;GET POINTER TO NAME
		LOAD B,FKHAN,(C);GET FORK HANDLE OR 0
		JUMPE B,[ERROR <Fork %1m doesn't exist>]
		JRST .+1]
	MOVEI A,(B)		;HANDLE TO A
	TRO A,400000		;MAKE SURE VALID LOOKING
	CAIN A,.FHSLF		;WANT SELF?
	 JRST [	MOVX B,WHLU	;MUST BE WHEEL TO LOOK AT SELF
		CALL PRVCK
		 JRST FRKNMX	;ULOSE
		RET]		;OK - RETURN
	CAIL A,400001		;CHECK VALID RANGE
	CAILE A,400777
FRKNMX:	ERROR <Fork handle must be between 1 and 777>
	MOVEM A,TMPSTR		;SAVE IT
	RFSTS			;CHECK EXISTENCE
	 ERJMP [ PUSH P,B	;CHECK IF IT'S REALLY THERE BUT HIDDEN
		CALL DGFRKS	;GET FORK STRUCTURE TABLE
		 ERROR <Fork table not available> ;NOT BLOODY LIKELY, BUT BE READY JUST IN CASE
		POP P,B		;SET UP FOR ANOTHER RFSTS% CALL
		MOVE A,TMPSTR
		RFSTS		;DOES IT REALLY EXIST?
		 ERJMP CJERRE	; NO, COMPLAIN
		JRST .+1 ]	;IT'S THERE ALL RIGHT, SO PROCESS IT.
	TLNE A,077700		;SEE IF ASSIGNED
	 ERROR <No such fork>
	MOVE A,TMPSTR		;RETURN FORK HANDLE
	CAIN A,.FHSLF		;DON'T CHECK IF "FORK 0"
	 RET
	SKIPN B,SLFTAB(A)	;KNOW ABOUT THIS FORK?
	 JRST CHKXST		; NO, BUT CHECK IF IT EXISTS ANYWAY AND WE AREN'T AWARE OF IT
GETOWN:	HLRZ B,.FKOWN(B)	;GET OWNER HANDLE
CHKOWN:	CAIE B,.FHSLF		;OURS?
	 ETYPE < %% Fork is not a direct inferior%_>
	RET

CHKXST:	MOVEI D,BUF0		;GET ADDRESS OF FIRST FORK
CHKFRK:	HRRZ C,1(D)		;FORK'S HANDLE FROM FORK STRUCTURE TABLE
	CAMN C,A		;IS THIS THE ONE WE'RE LOOKING FOR?
	 JRST FNDFRK		; YES, GO ENTER IT IN THE FORK TABLE
	ADDI D,3		;ELSE GET NEXT FORK (EACH ENTRY IN TABLE IS 3 WORDS LONG)
	SKIPE 1(D)		;ARE THERE ANY FORKS LEFT?
	 JRST CHKFRK		; YES, SEE IF THIS IS THE ONE WE WANT
	ETYPE < %% Unknown fork%_> ; NO, IT DOESN'T EXIST.
	RET
FNDFRK:	MOVEM A,TMPSTR		;PRESERVE FORK HANDLE
	MOVE Q1,D		; AND ADDRESS OF ITS STRUCTURE TABLE.
	MOVEI A,.FKSZE		;SIZE OF TABLE ENTRY FOR FORK
	MOVEI B,XDICT
	CALL GETMEM		;GET BLOCK OF STORAGE
	 JRST [	MOVE A,TMPSTR	;NONE AVAILABLE, SO JUST SET FORK
		HLRZ B,1(Q1)	; POINTER WITHOUT MAKING ENTRY.
		JRST CHKOWN]
	MOVE A,TMPSTR		;RESTORE HANDLE
	HLRZ D,1(Q1)		;GET POINTER TO SUPERIOR FORK
	SKIPN D			;IS IT REALLY AN INFERIOR FORK?
	 ERROR <Invalid fork number> ; NO, BOMB OUT. THIS IS PRETTY UNLIKELY!
	HRLZ D,1(D)		;GET HANDLE OF SUPERIOR
	MOVEM D,.FKOWN(B)	;STORE IT IN FORK TABLE
	SETOM .FKEDL(B)		;DON'T DO ANY E/D
	HRRZM B,SLFTAB(A)	;STORE POINTER TO ENTRY
	HRRZI D,.FKPTM+1(B)	;CLEAR FORK MODES
	HRLI D,-1(D)
	SETZM .FKPTM(B)
	BLT D,.FKPTM+NTTYMD+1(B)
	JRST GETOWN		;CHECK IF IT'S AN INFERIOR FORK, THEN FINISH
;MISC FORK COMMANDS

;GIVE A FORK A (NEW) NAME

.NAME::	NOISE <CURRENT FORK AS>
	WORDX <Name to call fork by>
	 CMERRX
	CONFIRM
	SKIPG A,FORK		;MUST HAVE FORK
	 ERROR <No current fork>
	LDB B,[POINT 7,ATMBUF,6]
	SKIPN B			;CHECK FOR NULL NAME
	 ERROR <No name given>
	MOVE Q1,SLFTAB(A)	;POINT TO FORK DATA BLOCK
	CALL DELNAM		;DELETE OLD NAME
	HRROI B,ATMBUF		;POINT NAME TYPED
	CALLRET ADDNAM		;PUT NEW FORK IN TABLE AND RETURN

;KEEP A FORK

.KEEP::	NOISE <FORK>
	CALL FRKNAM		;GET ITS NAME
	MOVX B,FK%KPT		;LIGHT FLAG SO ANNKEP DOESN'T ANNOUNCE ANYTHING
	IORM B,SLFTAB(A)
	CALLRET ANNKEP		;PUT FORK'S NAME IN TABLE OF KEPT FORKS

;UNKEEP A FORK

.UNKEE::NOISE <FORK>
	CALL FRKNAM		;GET NAME
	MOVX B,FK%KPT
	SKIPE CCKEEP		;KEEPING INTERRUPTED FORKS?
	 TXO B,FK%INT		;YES - LIGHT THIS BIT ALSO
	TDNN B,SLFTAB(A)	;FORK INTERRUPTED OR KEPT?
	 JRST [	TYPE <%Fork not kept>
		RET]
	ANDCAM B,SLFTAB(A)	;CLEAR BIT(S)
	HRRZ A,SLFTAB(A)	;GET ADDRESS OF FORK BLOCK
	HRRO A,.FKNAM(A)	;GET POINTER TO POSSIBLE NAME
	TRNN A,-1		;IF NO NAME, DON'T TRY TO REMOVE NAME
	RET
	CALLRET REMKEP		;REMOVE NAME IF IT WAS A KEPT FORK AND RETURN

;FREEZE A FORK

.FREEZ::NOISE <FORK>
	CALL FRKNAM		;ASK FOR NAME OR NUMBER; GET HANDLE IN AC A
	CAIN A,.FHSLF		;GOT OURSELF?
	JRST FRKNMX		;YES - THAT'S ILLEGAL
	FFORK			;FREEZE IT
	RET			;RETURN
;MERGE <FILE> COMMAND.
;GETS A FILE INTO CURRENT FORK WITHOUT RESETTING.
;PUTS BACK ENTRY VECTOR WORD THAT WAS THERE BEFORE COMMAND

.MERGE::NOISE <PROGRAM>
	CALL $GET1		;INPUT PROGRAM NAME

;SUBROUTINE ENTRY FOR "DDT" COMMAND.  PASS JFN IN A.

$MERGE:	STKVAR <MERJFN,<MERENT,2>,MERSEC>
	MOVEM A,MERJFN		;REMEMBER PROGRAM BEING MERGED
	MOVEM B,MERSEC		;REMEMBER SECTION NUMBER
	SKIPGE C,FORK		;SKIP IF EXEC HAS INFERIOR FORK
	JRST $GET2		;NO FORK, CREATE ONE, GET PROG, USE ITS ENTRY.
	MOVE A,C		;FORK HANDLE TO A
	CALL GETENT		;GET ENTRY VECTOR
	DMOVEM B,MERENT		;SAVE IT
	MOVE A,MERJFN		;TELL $GET2 WHAT PROGRAM TO GET
	MOVE B,MERSEC
	CALL $GET2		;GET PROGRAM
	MOVE A,FORK		;FORK HANDLE AGAIN
	DMOVE B,MERENT		;GET SAVED ENTRY VECTOR
	CALLRET SETENT		;SET ENTRY VECTOR AND RETURN

;SUBROUTINE TO INPUT A PROGRAM NAME.
;FIRST PART OF GET, RUN, MERGE.
;
;Returns:	A/	jfn
;		B/	-1 or section to use

$GET1:	SETZ A,			;NO DEFAULT FOR DEVICE OR DIRECTORY
GET1S:	STKVAR <SGJFN>
	CALL CPFN		;INPUT PROGRAM NAME AND ASSIGN JFN
	 CMERRX			;PRINT COMMAND ERROR IF CAN'T GET NAME
	MOVEM A,SGJFN		;REMEMBER JFN
	CALL GSWIS		;GET SWITCHES
	MOVE B,A		;RETURN SECTION IN B
	MOVE A,SGJFN		;RETURN JFN IN A
	RET

;GSWIS gets switches for GET-class commands.
;
;Returns:	A/	-1 or special section

GSWIS:	TRVAR <USESEC>
	SETOM USESEC		;SAY NO SPECIAL SECTION TO USE
;**;[946]	Add one line at GSWIS+1L.	FEB-04-83	YKT
	SETZM Q3		;[946] CLEAR THE FLAG
;**;[718] ADD 3 LINES AT GSWIS:+2L	TAM	30-MAR-82
	SKIPE MONVER		;[718] VERSION 5 OR LATER?
	JRST [	CONFIRM		;[718] NO, JUST CONFIRM
		JRST GET4]	;[718] AND RETURN -1 IN A
;**;[946]	Add 2 statements at GET3	FEB-04-83	YKT
GET3:   SKIPE Q3		;[946] IS USE-SEC: SW ALREADY PARSED?
	JRST [MOVEI B,[FLDDB. .CMCFM]	;[946] YES, DON'T PARSE IT AGAIN
	      SETZM Q3			;[946] CLEAR THE FLAG
	      JRST .+2]			;[946] 
	MOVEI B,[FLDDB. .CMSWI,,GETSWI,,,[
		  FLDDB. .CMCFM]]	;NO, 
	CALL FLDSKP		;SEE WHAT'S BEING TYPED
	 CMERRX
	LOAD D,CM%FNC,.CMFNP(C)
	CAIN D,.CMSWI		;SWITCH?
	JRST [	CALL GETKEY	;YES, SEE WHICH ONE
		CALL (P3)	;EXECUTE THE SWITCH
;**;[946]	Add one line 		FEB-04-83	YKT
		SETOM Q3	;[946] SET THE FLAG ON
		JRST GET3]	;GET MORE INPUT
;**;[718] ADD A LABEL AT GET3:+9L	TAM	30-MAR-82
GET4:	MOVE A,USESEC		;[718] RETURN -1 OR SECTION IN A
	RET

;Table of switches for GET-class commands

GETSWI:	TABLE
	T USE-SECTION:,,GUSE
	TEND

GUSE:	OCTX <Section to get program into>
	 CMERRX <Invalid section number>
	MOVEM B,USESEC		;REMEMBER SPECIFIED SECTION
	RET
;ERUN COMMAND - RUN A PROGRAM AS AN EPHEMERON

.ERUN::	NOISE <PROGRAM>
	MOVEI A,[ASCIZ "SYS:"]	;DEFAULT TO SYS:
	CALL CPFN		;INPUT PROGRAM NAME AND GET JFN
	 JRST [	MOVE A,ERCOD	;PRINT ERROR
		JRST CJERR]
	CONFIRM
	CALLRET REPH		;START IT UP

;R COMMAND.  EQUIVALENT TO RUN <SUBSYS>...

.R::	NOISE <PROGRAM>
	MOVEI A,[ASCIZ /SYS:/]
	CALL GET1S		;READ PROGRAM NAME AND SWITCHES
	PUSH P,[..STRT]		;SET UP TO START AFTER GET
	JRST GET1		;JOIN GET

;RUN <PROGRAM> COMMAND = GET + START

.RUN::	PUSH P,[..STRT]		;SET RETURN TO JOIN "START" COMMAND,
				;FALL INTO "GET".

;GET <FILE> COMMAND.
;RESETS THEN CREATES ONE FORK AND GETS PROGRAM INTO IT.
;CODED IN SUBROUTINES SO CODE CAN BE SHARED WITH "MERGE".

.GET::	NOISE <PROGRAM>
	CALL $GET1		;INPUT PROGRAM NAME

;R COMMAND JOINS HERE AFTER CALLING CPFN AND SETTING
; RETURN TO JOIN START COMMAND (..STRT).

GET1:	PUSH P,A		;SAVE JFN
	PUSH P,B	   	; AND SECTION
	CALL ERESET		;CLOSE FILES, KILL ALL INFERIOR FORKS.
	POP P,B			;RESTORE SECTION
	POP P,A			; AND JFN
	CALLRET $GET2		;GET THE PROGRAM AND RETURN
;GET...
;SUBROUTINE TO GET A PROGRAM INTO CURRENT FORK, FOR GET, RUN, AND MERGE.
;
;Accepts:	A/	jfn
;		B/	-1 or special section

$GET0::	HRROI B,-1		;SPECIAL ENTRY TO FORCE NO SPECIAL SECTION
$GET2::	STKVAR <GETJFN,GETSEC,<GBLK,1+.GBASE>>

;IF THERE IS NO INFERIOR FORK, CREATE ONE.

	MOVEM A,GETJFN		;REMEMBER WHICH FILE TO GET
	MOVEM B,GETSEC
   REPEAT 0,<			;ELIMINATE ONE BAD IDEA
	CALL PNTMES		;ALWAYS MAKE SURE SYSTEM MESSAGES HAVE
		;BEEN PRINTED BEFORE ALLOWING ANY PROGRAMS TO BE RUN.
		;THIS PREVENTS PROBLEM OF SYSTEMS THAT START UP SPECIAL
		;PROGRAMS FROM NEVER SEEING SYSTEM MESSAGES, BECAUSE
		;LOGIN.CMD OR COMAND.CMD RUNS PROGRAM.
   >
	SKIPL FORK
	JRST GET2B		;HAPPENS FOR "MERGE"
	CALL ECFORK		;CREATE A FORK

;DETERMINE SUBSYSTEM NAME BUT DON'T SETNM AT THIS POINT

	MOVE B,GETJFN		;JFN
	CALL SFKNAM		;SET FORK NAME

;PUT THE PROGRAM INTO THE FORK
				;FOR USE AT "WAITF"+2 BY "START", ETC.
GET2B:	HRR A,GETJFN
	HRL A,FORK
	SKIPGE B,GETSEC		;ANY SPECIAL SECTION?
	JRST GET2BE		;NO, USE OLD FORMAT GET
	TXO A,GT%ARG		;YES, TELL GET THERE'S AN ARG BLOCK ADDRESS IN B
	MOVEM B,.GBASE+GBLK	;STORE SECTION TO USE
	MOVX B,GT%BAS		;TELL GET TO USE THE SPECIFIED SECTION
	MOVEM B,.GFLAG+GBLK
	XMOVEI B,GBLK		;TELL GET WHERE ARG BLOCK IS
GET2BE:	CALL DOGET		;DO THE GET JSYS
	 JRST GETILI		;FAILED

	MOVE A,FORK		;GET FORK HANDLE
	HRRZ C,SLFTAB(A)	;GET ADDRESS OF FORK DATA
	SKIPL CODSEC(C)		;IS THERE ALREADY A SECTION SET UP?
	RET			;YES - DONE
	SKIPL B,GETSEC		;NO - WANT A SPECIAL SECTION?
	JRST GET2BF		;YES - SAVE THAT SECTION NUMBER
	CALL GETENT		;NO - USE ENTRY VECTOR SECTION AS CODE SECTION
	HLRZ B,C		;GET SECTION OF ENTRY VECTOR
	HRRZ C,SLFTAB(A)
GET2BF:	MOVEM B,CODSEC(C)	;REMEMBER WHICH SECTION CODE IS IN
	RET			;DONE

;ILLEG INST TRAP DURING GET JSYS
;TYPE EXEC ERROR MESSAGES FOR CERTAIN ERRORS

GETILI::CALL %GETER
	MOVE A,ERCOD		;SYSTEM ERROR CODE
	CAIN A,GETX1
	ERROR <Bad .EXE file format>
	CAIN A,GETX2
	ERROR <System special pages table full>
	JRST CJERR
;CREATE FORK FOR PROGRAM

ECFORK::CALL PIOFF		;DON'T ALLOW ^C WHILE POINTERS AMUK
	MOVEI A,.FKSZE		;SIZE OF FRKTBL ENTRY
	CALL GTBUFX		;GET BLOCK FROM PERMANENT FREE SPACE
	MOVE Q1,A		;SAVE ADDRESS IN Q1
	MOVX A,CR%CAP
	CFORK			;CREATE A FORK (SAME CAPS)
	 JRST [	PUSH P,A	;SAVE ERROR CODE
		MOVEI A,.FKSZE
		MOVE B,Q1	;BLOCK ADDRS
		CALL RETBUF	;RETURN BLOCK
		POP P,A		;RESTORE CODE
		JRST JERR]
	MOVEM A,FORK		;SAVE AS CURRENT FORK
	HRRZM Q1,SLFTAB(A)	;SAVE POINTER TO FORK DATA
	SETOM CODSEC(Q1)	;NO SPECIAL SECTION NUMBER YET
	MOVE A,FORK		;GET FORK HANDLE AGAIN
	FFORK			;TFORK REQUIRES IT TO BE FROZEN (STUPID RULE)
	CALL MRKTRP		;NEW FORK REQUIRES ANOTHER TFORK
	CALL PION		;ALLOW ^C NOW THAT BLOCKS ARE MADE AND SET UP
	MOVE A,FORK		;GET FORK HANDLE AGAIN
	SETO B,
	SETZ C,
	SKIPE PAXLFL		;LEGAL FOR COMPAT PKG?
	SCVEC			;NOPE - CLEAR IT
	FFORK			;LEAVE FORK FROZEN
	SKIPN BATCHF		;DON'T ALLOW ^C UNDER BATCH
	 SKIPE CCFLAG		;^C CAP ALLOWED AT ALL
	  JRST [MOVE A,FORK	;GET CURRENT CAPS
		RPCAP
		TXZ B,SC%CTC	;CLEAR ^C CAP
		TXZ C,SC%CTC
		EPCAP
		JRST .+1]
	MOVSI B,.FHSLF		;FLAG US AS OWNING FORK
	MOVEM B,.FKOWN(Q1)
	SETOM .FKEDL(Q1)	;NO LOCATION E/D YET
	MOVSI B,ITTYMD		;SET INITIAL MODES
	HRRI B,.FKPTM(Q1)	;LOC FOR PROGRAM/TTY MODES
	BLT B,.FKPTM+NTTYMD+1(Q1)
	RET

;SETTRP DOES THE APPROPRIATE SETTING UP TO REFLECT CHANGES IN THE TRAP
;STATUS FOR A FORK.
;IT WOULD PROBABLY BE NICE TO ABLE TO CAUSE JSYS TRAPPING FOR ONLY A PARTICULAR
;FORK, BUT THERE'S NO CANONICAL FORK HANDLE TO SAY THAT.  WE CAN'T MERELY USE
;400000+N BECAUSE THEN WE WON'T BE TRAPPING JSYS'S WHICH ARE INFERIOR TO N.
;THE CANONICAL FORK HANDLE WE NEED IS ONE WHICH MEANS "FORK N AND ALL ITS
;INFERIORS"!

SETTRP::STKVAR <TRPERR>
	SETZM TRPERR		;NO ERROR YET
	MOVEI C,JSBDEF		;TELL SYSTEM WHERE BIT TABLE IS
	MOVEI A,.FHINF		;TELL SYSTEM WHAT FORK (ALL OUR INFERIORS)
	HRLI A,.TFRAL		;FIRST REMOVE OLD SET SINCE .TFSET "OR"S
	TFORK
	 ERJMP [SETOM TRPERR	;FAILED, PROBABLY EXECUTE-ONLY OR PROCESSES NOT FROZEN
		JRST .+1]
	MOVEI A,JSBDEF		;POINT AT JSYS TRAP BLOCK
	CALL SKPNAZ		;SKIP IF WE'RE TRAPPING ON SOMETHING
	 JRST SETTR1		;TRAPPING ON NOTHING, SO SET NOTHING!
	MOVEI C,JSBDEF		;TELL SYSTEM WHERE BIT TABLE IS
	MOVEI A,.FHINF		;TELL SYSTEM WHAT FORK (ALL OUR INFERIORS)
	HRLI A,.TFSPS		;SAY TO SET CHANNEL
	MOVE B,[TRPCHN,,BITMLN*44] ;CHANNEL,,NUMBER OF BITS
	TFORK
	 ERJMP [SETOM TRPERR	;MARK THAT ERROR OCCURRED
		JRST .+1]
	HRLI A,.TFSET		;SAY WE'RE SETTING MONITOR CALLS
	TFORK			;TELL MONITOR WHICH JSYSES TO TRAP
	 ERJMP [SETOM TRPERR
		JRST .+1]
	SKIPE TRPERR		;ERRORS?
	JRST [	MOVEI A,JSBDEF	;YES, GET BLOCK ADDRESS
		CALL SKPNAZ	;SKIP IF NOT ALL BITS 0 IN BLOCK
		 JRST .+1	;IGNORE ERROR IF FAILURE BUT NOT TRAPPING
		ETYPE <%% Can't set up jsys traps - %?%%_>
		JRST .+1]
SETTR1:	SKIPN TRPERR		;DON'T SAY TRAPS O.K. IF THERE WERE ERRORS
	SETOM TRPOKF		;SAY TRAPS ARE OK
	RET
;SUBNAM - SET UP NAME OF PROGRAM BEING RUN IN SIXBIT.  USE IF
;FOR SUBSYSTEM NAME ALSO IF PROGRAM CAME FROM SUBSYS.
; A/ THE JFN
;	CALL SUBNAM
; RETURN +1, NAMES SET UP IN PTTYMD

SUBNAM::STKVAR <<SSBUF,EXTSIZ>,SUBJFN> ;PCL
	MOVEM A,SUBJFN		;SAVE JFN
	HRROI A,SSBUF		;SET UP PLACE TO PUT NAME STRING
	MOVE B,SUBJFN
	MOVSI C,(1B8)		;REQUEST NAME
	JFNS			;GET NAME FIELD FROM JFN
	 ERCAL JERRE
	HRROI A,SSBUF
	CALL GETSIX		;GET SIXBIT OF NAME
	 JFCL			;USE BEGINNING IF PROBLEM IN MIDDLE
	MOVEM A,TTWPNM(Q1)	;SAVE SUBSYSTEM INFO
	MOVEM A,TTWSNM(Q1)

;NOW SEE IF NAME CAME FROM DSK:<SUBSYS>, OTHERWISE USE (PRIV)

	MOVE A,SUBJFN		;RECOVER JFN
	DVCHR
	TXNN B,DV%MDD		;DEVICE HAS DIRECTORIES?
	JRST SUBNP		;NO, NOT DISK
	HRROI A,SSBUF		;SET UP PLACE FOR DIR NAME
	MOVE B,SUBJFN		;RECOVER JFN
	MOVSI C,(1B5)		;REQUEST DIRECTORY NAME
	JFNS
	 ERCAL JERRE
	HRROI A,SSBUF
	MOVE B,[POINT 7,[ASCIZ /SUBSYS/]]
	STCMP			;COMPARE NAMES
	JUMPE A,SUBNX		;JUMP IF NAMES THE SAME
	JRST SUBNP

;USE (PRIV) FOR SYSTEM NAME

SUBNP:	MOVE A,[SIXBIT /(PRIV)/]
	MOVEM A,TTWSNM(Q1)
SUBNX:	RET
;GOTO <OCTAL #>

.GOTO:	MOVE B,A		;ADDRESS INTO B FOR USE BELOW
	SKIPGE FORK		;CHECK HANDLE OF FORK KNOWN TO EXEC
	ERROR <No program>	;NONE AT ALL
	PUSH P,B		;SAVE B OVER MAPPF
	CALL MAPPF		;MAP PAGE CONTAINING ADDRESS. GETS ACCESS.
	 JRST CJERRE		;CAN'T MAP IT-- SAY WHY
	TXNN B,PA%PEX
	ERROR <No such page>
	TXNN B,PA%EX
	ERROR <Can't execute that page>
	POP P,B			;GET START ADDRESS BACK
	CALL NOPAT		;SET UP STUFF FOR PA1050 IF LOADED
	 NOP			;WE DON'T REALLY CARE WHETHER IT IS OR NOT.

	CALL CRSCAN		;RESCAN ON GOTO

;START FORK AT ADDRESS IN B
;"DDT" JOINS HERE

GOTO2::	CALL GOTOR		;DO THE WORK
	JRST (A)		;DISPATCH TO APPROPRIATE PLACE

;ROUTINE TO START THE LOWER FORK
;ACCEPTS IN B/	ADDRESS TO START AT (UNLESS DSFF IS ON)
;RETURNS +1:	ALWAYS - A/	ADDRESS TO DISPATCH TO WHEN FORK DONE

GOTOR::	CALL SETGO		;SET UP FOR PROGRAM RUNNING
	CALL DSFORK		;START FORK UNLESS PA1050 ALREADY DID
	CALLRET WAITA		;WAIT FOR IT TO TERMINATE

;GETENT gets the entry vector of a fork
;
;Accepts:	A/	fork handle
;
;Returns+1:	A/	fork handle
;		B/	length of entry vector
;		C/	address of entry vector

GETENT::XGVEC%			;TRY TO GET EXTENDED ENTRY VECTOR
	  ERJMP .+2		;OOPS
	RET			;SUCCESS - RETURN
	PUSH P,A		;ELSE SAVE FORK HANDLE
	CALL DGETER		;SEE WHY IT FAILED
	CAIE A,ILINS2		;OLD MONITOR?
	CALL JERR		;STRANGE ERROR, YECCH.
	POP P,A			;YES, DO IT THE OLD WAY - GET FORK HANDLE
	GEVEC
	HRRZ C,B		;RIGHT-JUSTIFY ADDRESS IN C
	HLRZ B,B		;AND LEAVE LENGTH IN B
	RET

;SETENT sets the entry vector for a fork
;
;Accepts:		same block as GETENT returns (see above)

SETENT::STKVAR <SFH,SLEN,SADR>
	MOVEM A,SFH		;SAVE ARGS IN CASE ERROR
	MOVEM B,SLEN
	MOVEM C,SADR
	XSVEC%			;SET VECTOR
	 ERJMP .+2		;FAILED
	RET			;DONE
	CALL DGETER		;FAILED, SEE WHY
	CAIE A,ILINS2		;OLD MONITOR?
	CALL CJERRE		;NO, OTHER ERROR SO TELL USER
	MOVE A,SFH		;RESTORE FORK HANDLE
	MOVE B,SLEN
	MOVE C,SADR		;DON'T ASSUME DGETER PRESERVES TEMPS
	TLNE C,-1		;WILL ADDRESS FIT IN RIGHT HALF?
	ERROR <Entry vectory addresses larger than 18 bits are illegal>
	HRL B,B			;PUT LENGTH IN LH
	HRR B,C			;AND ADDRESS IN RH OF B
	SEVEC			;DO IT THE OLD WAY
	 ERCAL CJERRE		;TELL USER OF FAILURE
	RET

;DSFORK starts fork unless PA1050 already did
;
;Accepts:	A/	handle
;		B/	DSFF + pc

DSFORK:	TXZE B,DSFF		;DON'T START FORK IF NOPAT DID
	 RET
	LSHC B,-^D36		;CLEAR FLAGS AND GET PC INTO C
	XSFRK%			;START THE FORK
	 ERJMP DSFRK1		;FAILED
	RET			;O.K.

DSFRK1:	CALL DGETER		;SEE WHY THE START FAILED
	CAIE A,ILINS2		;OLD MONITOR?
	CALL JERR		;NO, STRANGE ERROR
;**;[717] REPLACE 1 LINE WITH 5 AT DSFRK1:+3L	TAM	30-MAR-82
	MOVE A,RUNFK		;[717] FORK TO START
	MOVE B,C		;[717] PC INTO B FOR SFORK
	SFORK			;[717] START IT
	 ERCAL JERR		;[717]
	RET			;[717] OK

;"RUN" IS WITH "GET" ABOVE
CSTKLN==50			;ARG STACK SIZE FOR CSCAVE AND SAVE

DEFINE SAVSTG
<	TRVAR <SAVFIL,<SAVSTK,CSTKLN>,SAVJFN,SAVDEF,SCNTWD>
>
;CSAVE (CORE FROM) N (TO) N, (FROM) N (TO) N ... (ON) F

.CSAVE::SAVSTG
	SKIPGE FORK
	ERROR <No program>
	NOISE <on file>
        CALL SAVNMX
	MOVEI Q2,-1+SAVSTK	;FORM STACK POINTER TO ARG STACK
	HRLI Q2,-CSTKLN		;USE COUNT TO CATCH TOO MANY ARGUMENTS
SAVE1:	NOISE <WORDS FROM>
	DEFX <20>		;BEGINNING OF BLOCK DEFAULTS TO 20
	ADDRX <First word of memory block to be saved, in octal, or carriage return>
	 ERROR <Invalid word>
	PUSH Q2,B		;BUILD TABLE OF "SAVE" ARGUMENTS IN PUSHDOWN
	NOISE <TO>
	DEFX <777777>		;THIS IS DEFAULT END OF BLOCK
	ADDRX <Last word of memory block to be saved, octal>
	 ERROR <Invalid word>
	SUB B,(Q2)
	JUMPL B,[ERROR <Second address is smaller than first>]
	ADDI B,1
	TLNE B,1
	JRST [	MOVEI B,1B18	;FOR 0 TO 777777 LENGTH IS 1000000,
		HRLM B,(Q2)	;...WHICH IS MORE THAN 18 BITS,
		PUSH Q2,[XWD 400000,400000] ;...SO USE TWO BLOCKS OF HALF SIZE.
		JRST .+2]
	HRLM B,(Q2)		;FORM XWD LENGTH,LOCATION
	COMMAX <Comma to specify another block or confirm with carriage return>
	 CAIA			;NOT COMMA
	JRST SAVE1		;USER TYPED COMMA, INPUT ANOTHER PAIR
	MOVE Q3,[SAVE]		;GET APPROPRIATE JSYS
DOSAV:	CONFIRM
	PUSH Q2,[0]		;TERMINATE TABLE
	MOVE A,FORK
	MOVE B,SAVJFN
	CALL SFKNAM		;SET UP FORK NAME
	HRL A,FORK
	HRR A,SAVJFN
	MOVEI B,SAVSTK		;GET ADDRESS OF TABLE
	XCT Q3			;SAVE. IGNORES NON-EXISTENT OR 0 CORE.
	 ERJMP ILISSA
	MOVE A,SAVFIL		;GET POINTER TO NAME
	ETYPE < %1M Saved
>
	RET
;SAVE (PAGES FROM) N (TO) N, (FROM) N (TO) N ... (ON) FILE

.SAVE::	NOISE <on file>
	SAVSTG			;PCL *** Start ***
	MOVX A,GJ%FOU+GJ%MSG	;USE THESE FLAGS
	MOVEM A,CJFNBK+.GJGEN
	SETZM CJFNBK+.GJDEV	;NO DEVICE
	SETZM CJFNBK+.GJDIR	;NO DIRECTORY
	CALL SAVNAM		;MAKE THE DEFAULT FILESPEC
	MOVEM B,CJFNBK+.GJNAM
	HRROI A,[ASCIZ /EXE/]	;DEFAULT EXTENSION
	MOVEM A,CJFNBK+.GJEXT
	SETZM CJFNBK+.GJF2	;NO SPECIAL FLAGS
	MOVEI B,[FLDDB. .CMFIL,,,,,]
	CALL FLDSKP		;READ THE FILE NAME
	 CMERRX

	SKIPGE FORK		;PCL
	ERROR <No program>
	MOVEM B,SAVJFN		;PCL REMEMBER PROGRAM
	CALL SETSNM		;SET UP FILESPEC IN SAVFIL FOR CONFIRMATION MSG
	MOVEI Q2,-1+SAVSTK	;FORM STACK POINTER TO ARGUMENT LIST
	HRLI Q2,-CSTKLN		;CATCH OVERVERBOSITY
	SETZB C,D		;DEFAULT HIGH NUMBER TO HIGHEST PAGE IN LARGEST
				;EXISTING SECTION.  THIS MAKES THE EXEC WORK IN
				;MONITORS THAT DON'T HAVE EXTENDED SAVE YET
FHS2:	CAILE D,HIGHPN		;ARE WE IN RANGE OF LEGAL PAGES?
	JRST FHS3		;NOT ANYMORE.  LEAVE LOOP
	MOVE A,D		;GET NEXT PAGE TO CHECK
	HRL A,FORK		;TELL SYSTEM WHICH FORK
	RPACS			;SEE IF THIS PAGE EXISTS
	 ERJMP FHS1		;NO, SO DON'T UPDATE HIGHEST FOUND
	MOVE C,D		;EXISTS, SO REMEMBER HIGHEST EXISTENT PAGE
FHS1:	ADDI D,1000		;STEP TO NEXT SECTION
	JRST FHS2		;LOOP TO SCAN REST OF SECTIONS
FHS3:	MOVEI B,777(C)		;GET OCTAL PAGE NUMBER FOR DEFAULT
	MOVE A,CSBUFP		;POINT TO SOME SCRATCH SPACE
	MOVX C,FLD(8,NO%RDX)	;SAY OCTAL
	NOUT			;GET ASCII FOR NUMBER
	 ERJMP JERRE		;SHOULDN'T EVER FAIL
	MOVE A,CSBUFP		;POINT TO NUMBER
	CALL BUFFS		;ISOLATE IT
	MOVEM A,SAVDEF		;REMEMBER POINTER TO DEFAULT
SSAV1:	NOISE <PAGES FROM>
	DEFX <0>		;BEGINNING OF BLOCK DEFAULTS TO PAGE 0
	OCTX <First page of memory block to save, in octal,
or carriage return to save all of memory>
	 CMERRX
	PUSH Q2,B
	HRRZM Q2,SCNTWD		;FIRST ASSUME SINGLE-WORD ENTRY
	CAILE B,SS%FPN		;IS PAGE NUMBER TOO LARGE FOR SINGLE-WORD ENTRY
	JRST [	PUSH Q2,B	;YES, PUT IT IN SECOND WORD
		MOVX A,SS%EPN	;DENOTE THAT THIS IS AN EXTENDED ENTRY
		MOVEM A,@SCNTWD	;INITIALIZE FLAG WORD WITH SS%EPN
		JRST .+1]
	NOISE (TO)
	UDEF @SAVDEF		;USE CONJURED DEFAULT
	OCTX <Last page of memory block to be saved>
	 CMERRX
	SUB B,(Q2)		;FORM -# PAGES
	MOVN B,B		;..
	SUBI B,1		;..
	JUMPGE B,[ERROR <Second page number must be as large as first>]
	HRLM B,@SCNTWD
	MOVX A,SS%UCA+SS%CPY+SS%RD+SS%EXE+SS%WR	;DON'T CHANGE ACCESS
	IORM A,@SCNTWD		;PUT PROTECTION IN TABLE WORD
	COMMAX <Comma or confirm with carriage return>
	 CAIA			;NO COMMA TYPED
	JRST SSAV1		;COMMA TYPED, GO GET NEXT BLOCK
	MOVE Q3,[SSAVE]		;SET UP CORRECT JSYS
	JRST DOSAV

ILISSA:	CALL %GETER
	MOVE A,ERCOD
	MOVE C,SAVJFN
	CALLRET OPNERR		;ANALYZE ERROR

SAVNAM:				;PCL No noise
	SKIPLE C,FORK		;ACTIVE FORK?
	 SKIPN C,SLFTAB(C)	;YES - FRKTBL ENTRY
	  JRST SAVNM2
	SKIPE C,.FKPTM+TTWPNM(C) ;GET NAME IF ANY
	CAMN C,['(PRIV)']	;THIS IS STANDARD NULL NAME
	JRST SAVNM2
	MOVE A,CSBUFP		;SOME SCRATCH STRING SPACE
SAVNM1:	MOVEI B,"V"-100
	IDPB B,A
	SETZ B,
	LSHC B,6
	ADDI B,40
	IDPB B,A
	JUMPN C,SAVNM1
	IDPB C,A
	MOVE A,CSBUFP		;GET POINTER TO STRING
	CALL BUFFS		;ISOLATE IT
	MOVE B,A		;PUT POINTER TO DEFAULT NAME IN B
	HRL A,A			;PUT FILENAME STRING ADDRESS IN LEFT HALF
	HRRI A,[GETSAVE()]
	RET

SAVNM2:	HRROI A,[GETSAVE()]
	MOVEI B,0		;SAY NO NAME DEFAULT
	RET

;SAVNMX calls SAVNAM to set up defaults, and then parses the filename.

SAVNMX:	CALL SAVNAM
	CALL CSAVFN
	 JRST CERR
	MOVEM A,SAVJFN		;REMEMBER JFN
;	CALLRET SETSNM

;SETSNM sets up a pointer to the filespec used to save a program.

SETSNM:	MOVE B,SAVJFN		;JFN INTO B FOR JFNS
	MOVE A,CSBUFP		;POINT TO SOME FREE SPACE
	MOVEI C,0		;GET STANDARD FORMAT STRING
	JFNS
	MOVE A,CSBUFP
	CALL BUFFS		;ISOLATE THE NAME
	MOVEM A,SAVFIL		;REMEMBER FILENAME
	RET
;START
;DECODE AND CHECK SUBROUTINE ALSO USED BY REDIRECT/DETACH

$START::SKIPGE A,FORK		;HANDLE OF INFERIOR FORK, OR -1
	ERROR <No program>
	CALL GETENT		;GET ENTRY VECTOR
	CAIGE B,1
	ERROR <No START address>
	RET

;START COMMAND DISPATCHES HERE

.START::NOISE <PROGRAM>
	SETZM STAYF
	COMMAX <Comma to enter subcommands,
Octal start address
or Confirm with carriage return>
	 JRST .STRT0		;NO COMMA
	CONSTG			;ALLOCATE STORAGE
	MOVE A,FORK		;ASSUME CURRENT FORK UNLESS CHANGED
	MOVEM A,UFORK
	CALL .CONT3		;HANDLE SUB-COMMANDS (SET MODE)
	JRST .STRT1		;COMMON CODE

.STRT0:	CRRX <Octal start address
or Confirm with carriage return>
	 CAIA			;NOT JUST CR TYPED
	JRST .STRT1		;JUST CR, START AT REAL START ADDRESS
	ADDRX <Octal start address>
	 ERROR <Invalid address>
	MOVE A,B		;GET START ADDRESS INTO A
	CONFIRM
	JRST .GOTO

.STRT1:	CALL $START		;GET ADDRS
	JRST STR1

;"RUN" JOINS HERE
;REDIRECT/DETACH...(AND) START  JOINS HERE

..STRT::SETZM STAYF
STR1:	MOVNI B,1		;START CODE FOR PA1050
	CALL NOPAT		;SEE IF PA1050 THERE
	 JRST ..STCR		;YES
	SETZ B,			;ENTRY VECTOR INDEX 0 FOR START

;START FORK WHOSE HANDLE IS IN "FORK" USING ENTRY VECTOR INDEX IN B.
;"REENTER" JOINS HERE.

..STCR::CALL SETGO		;SET UP FOR PROGRAM RUNNING
	TXNN B,DSFF		;FORK ALREADY STARTED?
	CAIL B,1000		;NO, PROPER ENTRY VECTOR DISPATCH?
	JRST [	CALL DSFORK	;START FORK UNLESS PA1050 DID
		JRST WAITR]
	SFRKV			;START FORK USING ENTRY VECTOR (USES A,B)
	 ERJMP CJERRE

;GIVE LAST COMMAND BUFFER TO MONITOR FOR USER RSCAN

WAITR:	CALL CRSCAN
;START AND REENTER...
;CONTINUE AND GOTO JOIN HERE.
;ANY OF THE ABOVE WITH REDIRECT OR DETACH ALSO GET HERE.
;WAIT FOR FORK TO TERMINATE, AFTER DETACHING TERMINAL IF "DTACHF" ON.

;NOW WAIT FOR FORK TO TERMINATE

WAITF::	CALL WAITA		;WAIT FOR FORK TO TERMINATE
	JRST (A)		;DISPATCH TO NEXT ROUTINE TO BE RUN

;ROUTINE TO WAIT FOR A FORK TO TERMINATE
;RETURNS +1:	ALWAYS - A/	ADDRESS OF NEXT ROUTINE TO DISPATCH TO

WAITA::				;PCL

;CHECK AND DETACH TERMINAL

	TLNE Z,DTACHF		;"DETACH" COMMAND?
	DTACH			;YES, DETACH CONTROLLING TERMINAL.
	SKIPN STAYF		;DON'T SET PROGRAM MODE IF STAYING AT COMMAND LEVEL
	CALL SETPRG		;SAY PROGRAM MODE
	TLO Z,RUNF		;MAKE ^C KNOW THAT FORK NEEDS TO BE FROZEN
	MOVE A,RUNFK		;FORK WE ARE REALLY RUNNING
	RFORK			;RESUME IT
	UTFRK			;THIS IS NECESSARY IF THE FORK WAS JSYS-TRAPPED
	 ERJMP .+1		;UTFRK SEEMS TO FAIL FOR EXECUTE-ONLY FORKS
	MOVX B,FK%RUN		;SAY WE RAN IT
	SKIPE SLFTAB(A)		;KNOW ABOUT THIS ONE?
	 IORM B,SLFTAB(A)	;YES - MARK AS RUN
	MOVX B,FK%BKG
	SKIPE STAYF		;WANT TO STAY AT COMMAND LEVEL?
	 IORM B,SLFTAB(A)	;YES - SET BACKGROUND
	SETZM CIPF		;CLEAR "COMMAND IN PROGRESS", SO ^T REPORTS WHAT PROGRAM'S DOING
	SKIPE STAYF		;STAYING AT COMMAND LEVEL?
	JRST NOWAIT		;YES, DONT'T WAIT FOR PROGRAM TO HALT
WFORKX::WFORK			;PCL WAIT.  WFORKX: M-U-S-T BE ON WFORK
	FFORK			;FREEZE IT IMMEDIATELY
NOWAIT:	MOVE A,RUNFK		;HANDLE TO A (FORK JUST RUN)
	CALL RFTYMD		;SAVE PROGRAM MODES
	SKIPE STAYF		;STAY AT COMMAND LEVEL?
	 SETZM TTWPNM(Q1)	;YES - PREVENT
				;	@LOAD FOO
				;	MACRO: ...
				;	^C
				;	@CONTINUE STAY
				;	@...
				;	LINK: LOADING
				;	EXIT
				;	SAVE
				;	MACRO.EXE SAVED
				;NAME SHOULD BE "FOO".  THIS SETZM
				;WILL REQUIRE NAME AFTER "SAVE"
				;IF LINK LEFT NAME SOMEWHERE IN ADDRESS
				;SPACE OR PSB (FOR JSYS TO READ), WE
				;COULD MAKE "SAVE<CR>" WORK IN THIS CASE
	TLZ Z,RUNF		;SAY PROG'S TTY MODES NOT IN EFFECT
	MOVEI Q1,ETTYMD		;RESTORE EXEC'S TTY MODES
	SKIPN PCPRGR		;PCL Not if controlled program
	CALL LTTYMD		;..

;ANALYZE REASON FOR TERMINATION

	MOVEI B,.RFSFL+1	;SET UP FOR LONG FORMAT RFSTS
	MOVEM B,LRFSTS+.RFCNT
	HRLI A,(RF%LNG)		;ASK FOR LONG FORMAT
	MOVEI B,LRFSTS
	RFSTS			;READ FORK STATUS (HANDLE IN A)
	MOVE B,LRFSTS+.RFPSW	;GET STATUS WORD
	TLNN B,077700		;DISTINGUISH -1 FROM 0-5, 400000-400005.
	JRST FRKTRM
	SETOM FORK		;-1 = UNASSIGNED HANDLE, SAY NO FORK.
	SETOM RUNFK
	SETZM SYMOKF		;SAY WE NEED TO SET UP SYMBOL DATABASE
	ERROR <Program disappeared out from under EXEC!>

FRKTRM:	STKVAR <<PRBUF,PRLEN>,PRPTR>
	SKIPE STAYF		;NOT WAITING FOR PROGRAM TO STOP?
	JRST FRKTRN		;YES, SO DON'T WORRY ABOUT STATUS
	LOAD B,RF%STS,B		;GET JUST THE STATUS
	CAIE B,.RFRUN		;DON'T PRINT ANOTHER MESSAGE FOR JSYS TRAPS HERE
	CAIN B,.RFHLT		;SEE IF ERROR HALT
	CAIA			;STANDARD HALT OR JSYS TRAP (ALREADY REPORTED)
	JRST FKTRM1		;ERROR, GO ANALYZE.
	MOVE A,FORK		;GET FORK HANDLE
	SKIPE PCPRGR		;PCL Controlled program?
	RET			;PCL Yes, leave it at that
	HRLI	A,.PRARD	;SET TO READ
	MOVEI	B,PRBUF		;USE THIS
	MOVEI	C,PRLEN		;A GOOD MAX
	PRARG			;READ PROCESS ARGS
	  ERJMP	FRKTRN		;IGNORE IF FAILURE
	CAIGE	C,3		;MIN ARG
	JRST	FRKTRN		;IGNORE
	HLRZ	A,1+PRBUF	;CHECK HEADER
	MOVE	B,PRBUF
	CAIN	B,1		;# OF ARGS
	CAIE	A,(4B2+17B12)	;CHECK TYPE
	JRST	[CALL PRCLR	;CLEAR JUNK
		 JRST FRKTRN]	;EXIT TO MAIN LUP
	CALL	PRCLR		;CLEAR PROCESS ARGS
	HRRZ	B,1+PRBUF	;OFFSET OF FIRST ARG
	HRROI A,PRBUF		;ADDRESS OF START OF BLOCK
	ADD A,B			;MAKE BYTE POINTER TO FILESPEC (IF EXISTS)
	HRRZM A,PRPTR		;REMEMBER ADDRESS OF FILESPEC
	CALL BUFFS		;ISOLATE THE FILESPEC
	MOVE B,A		;POINTER TO FILESPEC IN B
	SKIPN	@PRPTR		;SEE IF NULL STRING
	SKIPA A,[CMAGN]		;YES - REDO LAST LOAD CMD
	MOVEI A,DOCC2		;TRY TO RUN IT
	RET

FRKTRN:	MOVEI A,CMDIN2		;GO TO START OF PARSER
	RET

PRCLR:	HRRZ	A,FORK		;SET TO CLEAR ARGS
	HRLI	A,.PRAST
	SETZB	B,C
	PRARG
	RET
;Here if fork terminates involuntarily after START or REENTER.
;Print reason.  Fork handle is in A, status in B.

FKTRM1:	LDB C,[POINTR .RFPSW+LRFSTS,RF%STS]	;GET REASON MINUS FROZEN BIT
	CAIN C,.RFABK		;ADDRESS BREAK?
	JRST [	SOSGE ABKCNT	;DECREMENT REPEAT COUNTER
		JRST FKTRM2	;COUNTER EXPIRED, REPORT IT
		MOVEI A,WAITF	;NOT EXPIRED, KEEP RUNNING FORK
		RET]		;DISPATCH VIA WAITF, CLEANING STACK
	CAIN C,.RFTRP		;JSYS/UUO TRAP???
	 JRST [	MOVE B,LRFSTS+.RFPPC	;LOAD PC FOR USE WITH %Y
		ERROR <JSYS or UUO trap at %2Y>]
	CAIN C,.RFIO		;PCL Waiting for I/O?
	SKIPN PCPRGR		;PCL Is it a controlled program?
	TRNA			;PCL No
	RET			;PCL Yes, the usual case
	CAIE C,.RFFPT		;FORCED TERMINATION (UNENABLED ERROR PSI)
	 ERROR <Unusual fork termination status %2O>
	LOAD C,RF%SIC,.RFPSW+LRFSTS ;(SIC) GET SOFTWARE CHANNEL (TYPE OF ERROR)
	CAIG C,^D35		;CHECK AGAINST TABLE LIMITS
	CAIGE C,0		;..
	 ERROR <Illegal PSI channel %3Q on forced termination>
	MOVE A,FORK		;LOAD FORK HANDLE FOR POSSIBLE %X
	MOVE B,LRFSTS+.RFPPC	;LOAD PC FOR POSSIBLE %Y BELOW

;MESSAGE TABLE ADDRESSED BY WHY IS ALSO USED BY INFORMATION PROGRAM.
;EXPECTS A TO CONTAIN FORK HANDLE FOR %X, B TO CONTAIN FULL WORD PC
;FOR POSSIBLE %Y, AND C TO CONTAIN THE CHANNEL FOR POSSIBLE %Q.

WHY::	XCT .+1(C)		;ERROR MESSAGE FROM TABLE FOLLOWING

ERROR <Channel %3Q interrupt at %2Y>	;Chan 0		These happen if program
ERROR <Channel %3Q interrupt at %2Y>	;Chan 1		activates channel but
ERROR <Channel %3Q interrupt at %2Y>	;Chan 2		does not EIR or SIR or
ERROR <Channel %3Q interrupt at %2Y>	;Chan 3		table word for channel
ERROR <Channel %3Q interrupt at %2Y>	;Chan 4
ERROR <Channel %3Q interrupt at %2Y>	;Chan 5
ERROR <Overflow at %2Y>			;Chan 6
ERROR <Floating overflow at %2Y>	;Chan 7
ERROR <Channel %3Q interrupt at %2Y>	;Chan 8
ERROR <Pushdown overflow at %2Y>	;Chan 9
ERROR <End-of-file at %2Y>		;Chan 10
ERROR <IO data error at %2Y>		;Chan 11
ERROR <Quota exceeded at %2Y>		;Chan 12
ERROR <File error 4 interrupt at %2Y>	;Chan 13 "file condition 4"
ERROR <Channel %3Q interrupt at %2Y>	;Chan 14. Time of day.
ERROR <Illegal instruction %1X>		;Chan 15. Prints PC, sys msg if JSYS.
ERROR <Illegal memory READ at %2Y>	;Chan 16
ERROR <Illegal memory WRITE at %2Y>	;Chan 17
ERROR <Illegal memory EXECUTE at %2Y>	;Chan 18
ERROR <Fork termination interrupt at %2Y> ;Chan 19
ERROR <File or swapping space exceeded at %2Y> ;Chan 20
REPEAT ^D15,<ERROR <Channel %3Q interrupt at %2Y>
>					;Chan 21-35
;Interrupt to here when a jsys or uuo trap occurs

TRPPSI::CALL SAVACS		;SAVE THE ACCUMULATORS
	CALL JINT0		;USE INNER ROUTINE SO LOCAL STORAGE CAN BE USED
	CALL RESACS
	DEBRK			;DISMISS THE INTERRUPT

JINT0:	TRVAR <RFCNT,RFPSW,RFPFL,RFPPC,RFSFL,JHAN,JINSTR,JNAME,JFNAME,JACC,REALF>
		;KEEP RFSTS LOCS IN ORDER AND USE TRVAR AND NOT STKVAR!!!
	RTFRK			;SEE WHO HAS JSYS-TRAPPED
	MOVEM A,JHAN		;REMEMBER HANDLE
	CALL PIOFF		;DON'T ALLOW ^C WHILE FORK CELL IS ALTERED
	EXCH A,FORK		;SAVE NEW FORK CELL, GET REAL
	MOVEM A,REALF		;REMEMBER REAL ONE
	MOVEM B,JINSTR		;REMEMBER INSTRUCTION
	MOVEI A,5		;SAY WE'LL ACCEPT 5 WORDS
	MOVEM A,RFCNT
	MOVE A,JHAN		;GET HANDLE
	IORX A,RF%LNG		;SAY LONG FORK
	MOVEI B,RFCNT		;SAY WHERE STATUS BLOCK IS
	RFSTS			;GET STATUS OF FORK
	MOVE C,SLFTAB(A)	;GET ADDRESS OF FORK BLOCK
	SKIPN D,.FKNAM(C)	;GET ADDRESS OF NAME
	 JRST [	MOVEI B,400000(A) ;GET FORK NUMBER IF NO NAME AND MAKE STRING
		MOVEI C,8	;OCTAL
		MOVE A,CSBUFP	;BUILD IN SCRATCH SPACE
		NOUT		;BUILD IT
		 ERCAL JERRE	;SHOULDN'T FAIL
		MOVE D,CSBUFP	;GET ADDRESS OF STRING
		JRST JIN1]
	HRRO D,D		;MAKE POINTER
JIN1:	MOVE A,D		;GET POINTER TO NAME STRING
	CALL BUFFS		;ISOLATE IT SO CSBUF CAN BE USED FOR OTHER THINGS
	MOVEM A,JNAME		;REMEMBER POINTER TO NAME OR NUMERIC STRING
	MOVE C,JINSTR		;GET INSTRUCTION THAT CAUSED TRAP INTO C
	LOAD A,YFLD,[OPENF]	;GET BIT VALUE FOR OPENF IN MASK
	MOVEI B,JSBDEF		;GET ADDRESS OF BIT MASK
	CAMN C,[OPENF]		;TRYING TO OPEN A FILE?
	SKIPN TFILEF		;SEE IF TRAPPING FILE-OPENINGS
	JRST JINNOF		;NO.
	MOVEI A,1		;READ JFN BEING OPENED
	CALL RANDOM
	 JRST [	HRROI A,[ASCIZ /?/]
		MOVEM A,JFNAME
		JRST GOTNAM]
	HRRZ B,A		;KEEP ONLY THE JFN
	MOVEI C,0		;STANDARD FORMAT
	MOVE A,CSBUFP		;POINT TO SOME FREE SPACE
	JFNS			;GET FILENAME
	 ERJMP [HRROI A,[ASCIZ /?/]
		MOVEM A,JFNAME
		JRST GOTNAM]
	MOVE A,CSBUFP		;POINT TO THE NAME
	CALL BUFFS		;ISOLATE IT
GOTNAM:	MOVEM A,JFNAME		;REMEMBER POINTER TO NAME
	MOVE B,JNAME
	ETYPE <%@%[Fork %2m opening %1m for >
	MOVEI A,2		;GET TYPE OF ACCESS
	CALL RANDOM
	 ERJMP [TYPE <?>
		JRST DONACC]
	MOVEM A,JACC		;REMEMBER ACCESS
	AND A,[OF%RD!OF%WR!OF%EX!OF%APP] ;KEEP ONLY BITS WE'RE LOOKING AT SO WE KNOW WHEN WE'RE ON LAST ONE

DEFINE PITM (BIT,MESSAGE,%FOO)<
	TXZE A,BIT			;IS BIT SET IN CALL TO OPENF?
	JRST [	TYPE <MESSAGE>		;PRINT MESSAGE
		JUMPE A,.+1		;NO COMMA OR "AND" IF LAST ITEM
		JFFO A,%FOO
	%FOO:	MOVE D,A
		ROT D,(C)		;SEE IF EXACTLY ONE MORE ITEM
		CAME D,[1B0]
		TYPE <, >		;SEVERAL MORE
		CAMN D,[1B0]
		TYPE < and >
		JRST .+1]
>
	PITM (OF%RD,reading)
	PITM (OF%WR,writing)
	PITM (OF%EX,executing)
	PITM (OF%APP,appending)
	MOVE B,JACC
	TXNE B,OF%THW
	TYPE < thawed>
	TXNE B,OF%RTD
	TYPE < restricted>
	TXNE B,OF%DUD
	TYPE < no updating>
DONACC:	ETYPE <]%_>
JINNOF:	LOAD A,OPFLD,JINSTR
	CAIE A,<JSYS>_-^D27	;A JSYS TRAP?
	JRST NOTJ		;NO
	LOAD A,YFLD,JINSTR	;GET WHICH JSYS THIS IS
	CAMN A,[FLD(OPENF,YFLD)];IS THIS OPENF THAT TRAPPED?
	SKIPE TOPENF		;YES.  ARE WE TRAPPING IT AS A JSYS?
	CAIA			;NOT OPENF OR IS OPENF AND WE'RE TRAPPING IT
	JRST NOTJ		;THIS IS OPENF BUT WE'RE NOT TRAPPING IT AS A JSYS
	MOVEI B,JSBDEF		;GET ADDRESS OF BIT MASK
	CALL SKPON		;SKIP IF THIS BIT IS ON IN THE MASK
	 JRST NOTJ		;NO
	MOVE A,JNAME		;YES, GET POINTER TO NAME OF FORK
	MOVE B,RFPPC		;GET PC
	SOJ B,			;SHOW LOCATION OF ACTUAL JSYS (OR XCT!)
	LOAD C,YFLD,JINSTR	;GET JSYS NUMBER
	HRRO C,JTAB(C)		;GET POINTER TO NAME OF JSYS
	ETYPE <%@[%1m trap %2Y/ %3M Ac's 1-4: >
	MOVSI Q1,-4		;PREPARE TO LOOP FOR 4 AC'S
NO0:	MOVEI A,1(Q1)		;GET AC TO READ CONTENTS OF
	CAIE A,1		;SEPARATOR BETWEEN VALUES BUT NOT BEFORE FIRST
	PRINT "\"
	CALL RANDOM
	 JRST [	TYPE <?>	;TYPE "?" IF CAN'T READ VALUE
		JRST NO1]
	ETYPE <%1O>
NO1:	AOBJN Q1,NO0		;LOOP FOR REST
	ETYPE <]%_>
NOTJ:	MOVE A,JNAME		;GET POINTER TO NAME
	CALL STREM		;RETURN FREE SPACE SINCE WE MAY COME THROUGH HERE
				;MANY TIMES BEFORE NEXT EXEC COMMAND!
	MOVE A,JHAN		;GET FORK HANDLE
	CALL FOWNER		;GET OWNER OF FORK.  NOTE THAT IT IS NECESSARY
			;TO FREEZE THE OWNER RATHER THAN THE FORK ITSELF, BECAUSE
			;IF AN INFERIOR FORK BEING USED BY SOME PROGRAM IS THE
			;ONE THAT TRAPPED AND WE ONLY FREEZE IT, IT'S SUPERIOR
			;WILL PROBABLY HANG FOREVER, SINCE THE MONITOR DOESN'T
			;ALLOW INFERIOR FORKS TO BE THAWED WHILE THEIR SUPERIORS
			;ARE FROZEN
	SKIPE TSTOPF
	FFORK			;IF WE'RE SUPPOSED TO STOP, FREEZE THE OWNER
	SKIPE TSTOPF		;DON'T WAKE UP WFORK IF WE'RE NOT STOPPING
	CALL FRZCHK		;WORRY ABOUT MONITOR BUG: WFORK WON'T NOTICE FORK!
	MOVE A,JHAN		;GET FORK HANDLE
	UTFRK			;UNTRAP FORK REGARDLESS OF WHETHER WE'RE STOPPING
	 ERJMP [ETYPE <%% Couldn't release fork from trap - %?%%_>
		JRST .+1]	;(EXECUTE-ONLY IS ONE REASON)
	MOVE A,REALF		;FIX FORK CELL
	MOVEM A,FORK
	CALLRET PION		;ALLOW ^C AGAIN

;HERE ON ADDRESS BREAK

FKTRM2:	SKIPG A,FORK		;GET FORK HANDLE
	JRST [	TYPE <No program> ;UNLESS THERE IS NONE
		JRST CMDIN2]
	HRLI A,.ABRED		;FUNCTION TO READ ADDR BREAK STUFF
	ADBRK			;GET ADDR BREAK INFO
	MOVE A,LRFSTS+.RFPPC	;GET USER'S PC IN CASE IT WAS A JSYS
	ETYPE <%_%%%Address break at location %2Y from user PC %1Y%%_>
	JRST FRKTRN		;GO TO MAIN SCANNER LOOP, CLEANING STACK


;HERE ON INFERIOR FORK TERMINATION INTERRUPT

INFTRM::CALL SAVACS		;PRESERVE AC'S
	CALL INFTR0		;ANALYZE FORK STATUS
	CALL FRZCHK		;CHECK ON FROZENNESS
	CALL RESACS		;RESTORE AC'S
	DEBRK			;DISMISS INTERRUPT

;FRZCHK SEES IF THE CURRENT FORK IS NOW FROZEN AND IF THE EXEC WAS WFORKING.
;IF SO, FRZCHK CAUSES THE CURRENT INTERRUPT LEVEL TO DISMISS TO THE INSTRUCTION
;AFTER THE WFORK, WHICH DUE TO MONITOR BUGS WOULDN'T NECESSARILY EVER RETURN!

FRZCHK:	MOVE A,RUNFK		;GET CURRENT FORK
	RFSTS			;GET ITS STATUS
	 ERJMP INF1		;IF FAILS, IGNORE
	TXNN A,RF%FRZ		;TURN OFF AND TEST FOR FROZENNESS
	RET	;NOT FROZEN, SO WFORK WILL FALL THROUGH NATURALLY
		;NOTE: WITHOUT THE ABOVE FROZENNESS TEST, THE EXEC
		;WILL BE FOOLED INTO THINKING WFORK SHOULD BE FORCED
		;TO DROP THROUGH IN THE EVENT OF "FORK 1" TERMINATING
		;WHILE CURRENT FORK IS "FORK 2".
INF1:	CALL GETLPC		;GET ADDRESS HOLDING INTERRUPT PC
	 RET			;NOTHING TO DO IF NO INTERRUPT IN PROGRESS
	HRRZ B,@A		;GET PC OF INTERRUPTED INSTR+1
	CAIE B,WFORKX
	CAIN B,WFORKX+1		;SEE IF WAITING FOR PROGRAM TO STOP
	TLO B,1000		;LIGHT USERMODE BIT IN PC
	IORM B,@A		;SO WFORK DROPS OUT
	RET

;SUBROUTINE TO ANALYZE A TERMINATED INFERIOR FORK'S STATUS
;AND TELL THE USER WHAT HAPPENED TO IT

INFTR0:	STKVAR <<TRFSTS,.RFSFL+1>,SRFPC>
	MOVSI Q1,-NFRKS		;LOOK AT ALL FORKS
INFTR1:	SKIPE Q2,FRKTAB(Q1)	;EXISTANT FORK?
	 TXNN Q2,FK%BKG		;BACKGROUND FORK?
	  JRST INFTR3		;NO - KEEP LOOKING
	MOVEI A,.FHSLF(Q1)	;FORM HANDLE
	MOVEI B,.RFSFL+1	;LENGTH OF LONG RFSTS BLOCK
	MOVEM B,.RFCNT+TRFSTS
	MOVEI B,TRFSTS		;POINT TO TEMP BLOCK
	TXO A,RF%LNG
	RFSTS			;READ ITS STATUS
	LDB C,[POINTR <.RFPSW+TRFSTS>,RF%STS] ;GET CODE
	CAIN C,.RFHLT		;HALTED?
	 JRST INFTR2		;YES - INFORM USER
	CAIN C,.RFTTY		;WANTS TTY?
	 JRST [	TXOE Q2,FK%TTY	;BLOCKED FOR TTY?
		 JRST INFTR3	;BEEN HERE BEFORE
		HRROI Q3,[ASCIZ "wants the TTY"]
		JRST INFTR4]	;INFORM USER FIRST TIME THROUGH
	CAIN C,.RFABK		;ADDRESS BREAK
	 JRST [	HRROI Q3,[ASCIZ "Address break"]
		JRST INFT2C]
	CAIN C,.RFTRP		;MAYBE JSYS TRAP
	 JRST [	HRROI Q3,[ASCIZ "JSYS/UUO trap at %2Y"]
		JRST INFT2C]
	CAIE C,.RFFPT		;FORCED TERMINATION?
	 JRST INFTR3		;NO - GO ON
	HRRZ C,.RFPSW+TRFSTS	;PSI CHL THAT CAUSED TERMINATION
	CAIG C,^D35		;CHECK VALID CHL
	CAIGE C,0
	 JRST [ HRROI Q3,[ASCIZ "Illegal PSI channel %3Q"]
		JRST INFT2C]
	HRRO Q3,WHY+1(C)	;SOFTWARE CHL REASON
	JRST INFT2C

INFTR2:	HRROI Q3,[ASCIZ "halted at %A"]
MIC,<
	MOVEI B,.FHSLF(Q1)	;FORM FORK HANDLE
	CAMN B,MICFRK		;IS THIS THE MIC?
	 JRST [	TXZ Q2,FK%BKG	;REMOVE FROM BACKGROUND
		MOVEM Q2,FRKTAB(Q1) ;STORE UPDATED STATUS
		JRST INFTR3]
>
INFT2C:	TXZ Q2,FK%BKG		;NO LONGER BACKGROUND
	TXNN Q2,FK%PRI!FK%PRO	;FORK HAVE PRIMARIES CHANGED?
	 JRST INFTR4		;NO - REPORT CONDITION
	MOVEI A,.FHSLF		;GET PRIMARY I/O FOR SELF
	GPJFN
	MOVE D,B		;SAVE IN D
	MOVEI A,.FHSLF(Q1)	;FORK HANDLE
	GPJFN			;GET INFERIORS JFNS
	TXZN Q2,FK%PRI		;PRIMARY INPUT CHANGED?
	 JRST INFT2A		;NO - LOOK AT OUTPUT
	HLRZ A,B		;JFN TO A
	CAIGE A,100		;IS IT A FILE? (BE CAREFUL)
	 CLOSF			;YES - CLOSE IT
	  JFCL
	HLL B,D			;RESET FROM OURS
INFT2A:	TXZN Q2,FK%PRO		;PRIMARY OUTPUT CHANGED?
	 JRST INFT2B		;NO - SET NEW PRIMARY JFNS
	HRRZ A,B		;JFN TO A
	CAIGE A,100		;FILE?
	 CLOSF			;YES - CLOSE IT
	  JFCL
	HRR B,D			;RESET FROM OURS
INFT2B:	MOVEI A,.FHSLF(Q1)	;FORK HANDLE
	SPJFN			;SET NEW PRIMARY JFNS
INFTR4:	MOVEM Q2,FRKTAB(Q1)	;UPDATE FORK FLAGS
	TXNN Q2,FK%NAM		;FORK HAVE NAME?
	 SKIPA Q2,[POINT 7,[ASCIZ "Fork %5P"]]
	  HRRO Q2,.FKNAM(Q2)	;POINT TO NAME STRING
	MOVEI A,.FHSLF(Q1)	;LOAD FORK HANDLE FOR POSSIBLE %X
	MOVE B,LRFSTS+.RFPPC	;SAVE THIS (%X USES)
	MOVEM B,SRFPC
	MOVE B,.RFPPC+TRFSTS	;LOAD PC FOR POSSIBLE %Y
	MOVEM B,LRFSTS+.RFPPC	;STORE IN LRFSTS ALSO
	HRRZ C,.RFPSW+TRFSTS	;LOAD PSI CHL FOR POSSIBLE %Q
	ETYPE <[%6\: %7\]%_>
	MOVE B,SRFPC		;RESTORE PC USED BY %X
	MOVEM B,LRFSTS+.RFPPC
INFTR3:	AOBJN Q1,INFTR1		;LOOP OVER ALL FORKS
	RET
;SETGO - SET UP EVERYTHING TO LEAVE EXEC TO PROGRAM MODE
;RETURNS A/ FORK HANDLE

SETGO::	PUSH P,B		;SAVE B OVER MAPPF
	SKIPN TRPOKF		;DON'T SET UP TRAPS UNLESS THEY NEED IT
	CALL SETTRP		;NO, SET THEM UP
	SETO A,
	CALL MAPPF		;UNSHARE MAPPED PAGE, IF ANY
	 JFCL			;UNMAP SHOULD NEVER FAIL
	POP P,B			;RESTORE
	CALL UTTYMD		;SET UP PROGRAM MODES
	MOVE A,FORK		;RETURN FORK HANDLE
	MOVEM A,RUNFK		;STORE IN RUNFK
	RET

;ROUTINE CALLED BY .CLOSE TO CLOSE ALL OPEN FILES IN COMPATIBLE PROGRAMS
;THIS ROUTINE CHECKS IF THE PROGRAM IS COMPATIBLE, THEN STARTS IT WITH
;A -5 ENTRY CODE (CLOSE COMMAND).
;RETURNS +1:	ALWAYS - ALL FILES UNMAPPED

CLOPAT::MOVNI B,5		;SET UP FOR NOPAT
	SETZM STAYF
	CALL NOPAT		;SEE IF THIS IS A COMPATIBLE PROGRAM
	 CALL GOTOR		;GO START COMPATIBLE PROGRAM AND WAIT FOR IT TO HALT
	RET			;ALL DONE, FILES ARE UNMAPPED

;ROUTINE TO SET UP FORK IF PA1050 HAS BEEN INVOKED. START, REENTER, CLOSE,
; GOTO, AND DDT ALL GO TO PA1050 INSTEAD OF THE PROGRAM.
; THE PREVIOUS FORK PC IS ALSO GIVEN TO PA1050, AND IT IN TURN
; FINDS THE PROGRAM'S OLD PC, SETS UP JOBOPC, AND STARTS THE PGM.
; WORD 6 OF THE PA1050 ENTRY VECTOR IS THE START LOCATION FOR THIS.
; LH OF WORD 7 IS WHERE TO STORE FUNCTION CODE: -1 START, -2 REENTER,
;  -3 DDT, +N GOTO N
; RH OF WORD 7 IS WHERE TO STORE FORK'S OLD PC
;
;Returns+1:	compatible program
;	+2:	non-compatible program

NOPAT:	STKVAR <PATCOD,SAVAC,SAVAC2>
	MOVEM B,PATCOD
	MOVE A,FORK
	GCVEC			;PA1050 ENTRY VECTOR
	 ERJMP NOPAXL		;IF NO FORK, THEN NOTHING TO BE DONE
	CAMN B,[-1]		;PA1050 DISABLED?
	JRST NOPAXL		;NO PA1050
	HLRZ C,B		;CHECK FOR LENGTH GREATER THAN 8
	CAIGE C,1000		;WHICH ELIMINATES OLD PA1050 VERSIONS
	CAIGE C,10		;AS WELL AS NON-PA1050 PGMS.
	JRST NOPAXL
	MOVEI A,6(B)
	MOVEM B,SAVAC		;DON'T CLOBBER ENTRY VECTOR INFO
	CALL LOADF		;GET PA1050 RESTART LOC
	 CALL CJERRE		;BOMB OUT (JRST NOPAXL WOULD CAUSE REENTER TO DO THE WRONG THING!)
	EXCH A,PATCOD		;SAVE IT, GET CODE WORD
	MOVE B,SAVAC		;RESTORE
	MOVEM A,SAVAC
	MOVEI A,7(B)
	CALL LOADF		;GET PTRS FOR RESTART DATA
	 CALL CJERRE		;CAN'T READ IT, ASSUME NO PA1050
	MOVEM A,SAVAC2
	MOVE A,FORK
	RFSTS			;GET FORK'S OLD PC
	HLRZ A,A
	CAIE A,400002		;HALT OR FORCE TERM?
	CAIN A,400003
	JRST [	MOVE A,FORK	;YES, MUST RESTART FORK
		LSHC B,-^D36	;CLEAR FLAGS AND GET PC INTO C
		XSFRK%
		 ERJMP NOPAX1	;FAILED - ASSUME NO PA1050
		JRST .+1]
	HRRZ A,SAVAC2		;PTR TO CELL FOR IT
	CALL STOREF		;STORE OLD PC IN PA1050 VARIABLE AREA
	 CALL CJERRE		;CAN'T SET IT, ASSUME NO PA1050
	HLRZ A,SAVAC2		;PTR TO CELL FOR CODE WORD
	MOVE B,SAVAC		;CODE WORD
	CALL STOREF		;STORE IT
	 CALL CJERRE		;CAN'T SET IT, ASSUME NO PA1050
	MOVE B,PATCOD		;RETURN PA1050 RESTART LOC IN B
	MOVNI A,0(B)		;IF RH OF WD 6 IS .L. 36, IT IS
	CAMG A,[-^D36]		;PSI CHANNEL TO BE GOOSED RATHER THAN
	RET			;A RESTART LOCATION
	MOVSI B,(1B0)		;COMPUTE PROPER BIT
	LSH B,0(A)
	MOVE A,FORK
	AIC			;BE SURE CHANNEL ON AND PSI ON
	EIR
	IIC
	MOVX B,DSFF		;TURN ON SPECIAL BIT TO SAY FORK ALREADY STARTED
	RET

DSFF==1B0			;BIT TO SAY DON'T START FORK (OUT OF THE WAY OF PC FIELD!)
NOPAXL:	SKIPA B,PATCOD
NOPAX1:	MOVE B,SAVAC2		;RETURN ORIGINAL START ADDRESS
	RETSKP			;SKIP TO SAY NO PA1050

;HAND LAST COMMAND LINE TO MONITOR FOR RSCAN

CRSCAN::PUSH P,A
	SKIPN A,RSPTR		;GET POINTER TO DATA FOR SENDING TO PROGRAM
	HRROI A,CBUF		;USE COMMAND ITSELF, IF NO SPECIAL LINE
	RSCAN
	 TYPE <
%RSCAN failure. Rescanned command truncated, will try to go on.
>
	POP P,A
	RET
;ROUTINES TO HANDLE EPHEMERALS
;ENTER WITH JFN IN A

REPH::	PUSH P,[CMDIN2]		;RETURN HERE
STEPH::	MOVEI B,0		;ENTRY VECTOR START OFFSET
REPH1::	STKVAR <PJFN,EVOFF>
	MOVEM A,PJFN		;SAVE JFN
	MOVEM B,EVOFF		;SAVE OFFSET
	SETO A,
	CALL MAPPF		;UNMAP FORK PAGE (IF ANY)
	CALL PIOFF		;MUST DISABLE ^C TO MUCK WITH EFORK
	MOVX A,CR%CAP		;PASS ON CAPS
	CFORK
	 JRST [	CALL PION
		ERROR <No forks left - "RESET" some>]
	FFORK			;MAKE SURE FROZEN
	MOVEM A,EFORK		;SAVE FORK HANDLE
	MOVEI A,.FHSLF		;GET CURRENT CAPS (INCLUDING ENABLED)
	RPCAP
	MOVE A,EFORK		;AND PASS THEM ON
	EPCAP
	MOVE A,PJFN		;JFN TO A (BEFORE STACK IS MUNGED)
				;*** BEWARE OF STKVAR VARIABLES ***
	ADJSP P,2		;MAKE SOME SPACE FOR PROGRAM NAMES
	MOVEI Q1,-5(P)		;DUMMY POINTER FOR SUBNAM
	CALL SUBNAM		;SET SUBSYS NAME
	POP P,B			;RECOVER DUMMY NAME ENTRIES
	POP P,A
				;*** STACK RECOVERED ***
	SETSN
	 ERJMP .+1
	CALL PION		;RE-ENABLE ^C
	MOVEI A,GETILI		;WHERE TO GO ON "GET" ERROR
	MOVEM A,ILIDSP
	HRRZ A,PJFN		;GET JFN OF PROGRAM NAME
	HRL A,EFORK		;FORK HANDLE
	GET
	SETZM ILIDSP		;CLEAR ERROR ADDRS
	MOVE A,EFORK
	CALL CRSCAN		;LOAD RE-SCAN BUFFER IF NECESSARY
	MOVE B,EVOFF		;RECOVER E-V OFFSET
	SFRKV			;START FORK
	SETZM CIPF		;NO COMMAND IN PROGRESS
	RFORK			;THAW IT
WEPHM:	WFORK			;WAIT FOR IT TO TERMINATE
	CALL PIOFF		;DISABLE ^C
	MOVEI Q1,ETTYMD		;RESTORE EXEC TTY MODE
	CALL LTTYMD
	MOVE A,EFORK
	FFORK			;FREEZE IT
	MOVEI B,.RFSFL+1	;SET UP FOR LONG FORM RFSTS
	MOVEM B,LRFSTS+.RFCNT
	TXO A,RF%LNG		;ASK FOR LONG FORM
	MOVEI B,LRFSTS
	RFSTS			;READ FORK STATUS (HANDLE IN A)
	MOVE A,LRFSTS+.RFPSW	;GET STATUS WORD
	TXZ A,RF%FRZ		;WE KNOW ITS FROZEN
	CAMN A,[.RFHLT,,0]	;HALTED?
	 JRST [	MOVE A,EFORK	;YES - JUST KILL IT OFF
		KFORK
		SETOM EFORK	;NO MORE EPHEMERON
		CALLRET PION]	;EXIT (CMDIN2)
	TLNE A,077700		;FORK EXISTS?
	 JRST [	SETOM EFORK	;NO - MUST HAVE SELF DESTRUCTED
		CALL PION
		ERROR <Ephemeron committed suicide!>]
	CALL PION
	TYPE <During Ephemeron: >
	MOVE B,LRFSTS+.RFPSW
	JRST FKTRM1		;TELL OF LOSSAGE
SUBTTL Routines for printing symbolic expressions

;SMORNM prints a value as a symbol or as a number, but never as a symbol
;plus an offset.  This is useful for AC fields, where you'd like to see either
;
;	SETZB C,FOO
;	      -
;	or
;
;	SETZB 3,FOO
;	      -
;
;but never
;
;	SETZB B+1,FOO
;	      ---
;
;Accepts:	A/	value

SMORNM:	STKVAR <SVAL>
	MOVEM A,SVAL		;REMEMBER VALUE
	CALL GNT		;GET NEAREST SYMBOL
	JUMPE B,SM1		;IF NO NAME, JUST TYPE NUMERICALLY
	CAMN A,SVAL		;WAS AN EXACT MATCH FOUND?
	JRST [	MOVE A,B	;YES, GET NAME
		CALLRET TYPSYM]	;TYPE ITS NAME AND RETURN
SM1:	MOVE A,SVAL		;NO EXACT SYMBOL FOUND, SO TYPE NUMERICALLY
	ETYPE <%1O>
	RET

;GNT gets the nearest symbol equal to or less than a given value.
;
;Accepts:	A/	value
;
;Returns+1:	A/	value of nearest symbol equal to or less than given address or 0
;		B/	name of tag or 0

GNT:	STKVAR <GNNAME,WTAG,GNADD,WSYM,CSF>
	MOVEM A,WTAG		;REMEMBER WHICH TAG WE'RE LOOKING FOR
	CALL CHKSYM		;MAKE SURE SYMBOL TABLE INFO UP TO DATE
	SETZM GNNAME		;GIVE 0 IF NO GOOD TAG FOUND
	SETZM GNADD		;0 IF NO GOOD TAG FOUND
	HRLOI B,377777		;INITIALIZE BEST DISTANCE SO FAR
	MOVEM B,CSF
	MOVE A,SYMBEG		;START WITH FIRST ADDRESS OF SYMBOL TABLE
	MOVEM A,WSYM
GNT2:	CAMLE A,SYMEND		;WITHIN SYMBOL TABLE STILL?
	JRST [	MOVE A,GNADD	;GET BEST ADDRESS FOUND
		MOVE B,GNNAME	;GET NAME
		RET]
	CALL GETSYM		;GET THE SYMBOL NAME AND VALUE
	MOVE D,WTAG		;GET COPY OF ONE WE'RE LOOKING FOR
	SKIPL B			;SKIP NEGATIVE SYMBOLS
	CAMGE D,B		;SKIP TAGS AFTER TARGET LOCATION
	JRST GNT1
	TXNE A,SCFLD		;PROGRAM NAME?
	TXNE A,SCHIDE		;HIDE THIS SYMBOL?
	JRST GNT1		;YES, SO IGNORE THIS SYMBOL
	SUB D,B			;CALCULATE HOW CLOSE WE ARE
	JUMPE D,[LOAD B,SNFLD,A	;GET NAME
		 MOVE A,WTAG	;EXACT MATCH IS BEST POSSIBLE
		 RET]
	CAML D,CSF		;IS THIS SYMBOL CLOSEST SO FAR?
	JRST GNT1		;NO, SKIP IT
	MOVEM B,GNADD
	MOVEM A,GNNAME		;REMEMBER BEST NAME SO FAR
	MOVEM D,CSF		;REMEMBER HOW GOOD IT IS
GNT1:	MOVEI A,2
	ADDB A,WSYM		;PROGRESS TO NEXT SLOT
	JRST GNT2

;AVALUE evaluates an ascii symbol name, with optional module name and
;ampersand preceding the symbol name.
;The "symbol" may also be an octal integer, or a decimal integer (identified
;with a decimal point), or a floating point number (identified by more digits
;after the dot).
;
;Accepts:	A/	pointer
;
;Returns+1:	symbol undefined
;	+2:	A/	value
;		B/	location of info in symbol table, or -1 if number

AVALUE:	STKVAR <ECNT,DPCNT,DECVAL,OCTVAL,FLTFLG,NUMFLG,DIGIT,MODNAM,SYMNA>
	CALL FIXPT		;FIX -1 IN LEFT HALF
	SETZM MODNAM		;USE 0 IF NO MODULE NAME
	MOVE B,CSBUFP		;GET SOME SCRATCH SPACE
AV0:	MOVEM B,SYMNA		;REMEMBER SYMBOL POINTER FOR IF THERE'S NO MODULE NAME
	SETZM DECVAL		;INITIALIZE DECIMAL VALUE
	SETZM OCTVAL		;INITIALIZE OCTAL VALUE
	SETOM NUMFLG		;VALUE COULD STILL BE A NUMBER
	SETZM FLTFLG		;NOT FLOATING POINT YET
	SETZM DPCNT		;NO DECIMAL POINTS SEEN YET
	SETZM ECNT		;NO E'S SEEN YET
AV1:	ILDB C,A		;GET NEXT CHARACTER FROM ASCII
	JUMPE C,AV2		;IF NULL, END OF NAME
	CAIN C,"&"		;END OF POSSIBLE MODULE NAME?
	JRST [	MOVEI C,.CHNUL	;YES, PUT NULL AFTER MODULE NAME
		IDPB C,B
		MOVE D,CSBUFP	;REMEMBER POINTER TO MODULE NAME
		MOVEM D,MODNAM
		JRST AV0]
	IDPB C,B		;NO, STORE NAME SO FAR
	CAIE C,"E"		;E IS USED FOR EXPONENTIATION
	CAIN C,"."		;DECIMAL POINT
	 JRST [	SETOM FLTFLG	;YES, IT MIGHT BE FLOATING POINT
		CAIN C,"E"
		AOS ECNT	;COUNT E'S
		CAIN C,"."
		AOS DPCNT	;COUNT DECIMAL POINTS
		JRST AV1]
	CAIL C,"0"		;IS CHARACTER A DIGIT?
	CAILE C,"9"
	JRST [	SETZM NUMFLG	;NO, REMEMBER WE DON'T HAVE A NUMBER
		JRST AV1]
	SUBI C,"0"		;MAKE REAL DIGIT
	MOVEM C,DIGIT		;REMEMBER DIGIT
	MOVE C,OCTVAL		;ACCUMULATE OCTAL VALUE
	ASH C,3
	ADD C,DIGIT
	MOVEM C,OCTVAL
	MOVE C,DECVAL		;ACCUMULATE DECIMAL VALUE
	IMULI C,5+5
	ADD C,DIGIT
	MOVEM C,DECVAL
	JRST AV1		;LOOP FOR MORE OF NAME

AV2:	LDB D,B			;GET LAST CHARACTER OF STRING
	MOVEI C,.CHNUL
	IDPB C,B		;PUT NULL AFTER SYMBOL NAME
	SOSG ECNT		;MORE THAN A SINGLE E?
	SOSLE DPCNT		;MORE THAN A SINGLE DECIMAL POINT?
	SETZM NUMFLG		;TWO OR MORE E'S OR TWO OR MORE DP'S - NOT A NUMBER!
	SKIPN NUMFLG		;IS IT A NUMBER?
	JRST AV3		;NO
	CAIE D,"E"
	CAIN D,"."
	SETZM FLTFLG		;FLOATING NUMBERS DON'T END WITH DOT OR "E"
	SKIPN FLTFLG		;FLOATING POINT NUMBER?
	JRST [	MOVE A,OCTVAL	;NO, GET OCTAL VALUE
		CAIN C,"."	;END WITH DECIMAL POINT?
		MOVE A,DECVAL	;YES, GET DECIMAL VALUE
		JRST AV4]
	MOVE A,SYMNA		;FLOATING NUMBER, POINT TO IT
	FLIN			;GET FLOATING VALUE
	 ERROR <Invalid floating point number in expression>
	MOVE A,B
AV4:	MOVNI B,1		;PUT -1 IN B TO INDICATE NUMBER
	RETSKP

AV3:	MOVE A,MODNAM		;GET POINTER TO MODULE NAME
	CALL ASCR50		;MAKE RADIX50
	MOVEM A,MODNAM		;REMEMBER
	MOVE A,SYMNA		;GET SYMBOL NAME POINTER
	CALL ASCR50		;GET RADIX50
	MOVE B,MODNAM		;GET MODULE NAME
	CALLRET GVALUE		;GET VALUE OF SYMBOL AND RETURN

;ASCR50 changes ascii to radix50 symbol.
;
;Accepts:	A/	pointer to asciz symbol
;
;Returns +1:	A/	radix50 symbol

ASCR50:	CALL FIXPT		;CHANGE -1,,FOO TO 440700,,FOO
	MOVE B,A		;SYMBOL INTO B
	MOVEI A,0		;START WITH CLEAR RESULT
ASCR1:	ILDB C,B		;GET NEXT CHARACTER
	JUMPE C,R		;DONE IF 0
	IMULI A,50		;MAKE ROOM FOR THIS NEXT CHARACTER
	CAIN C,"%"		;CHECK FOR SPECIAL SYMBOLS
	ADDI A,47		;CODE FOR PERCENT SIGN
	CAIN C,"."		;CHECK FOR SPECIAL SYMBOLS
	ADDI A,45		;CODE FOR A DOLLAR SIGN
	CAIN C,"$"		;CHECK FOR SPECIAL SYMBOLS
	ADDI A,46		;CODE FOR A PERIOD
	CAIL C,"A"		;IN RANGE OF A LETTER?
	CAILE C,"Z"		;WELL?
	SKIPA 			;NO
	ADDI A,13-"A"(C)	;A TO Z MAPS TO 13 TO 44
	CAIL C,"0"
	CAILE C,"9"
	SKIPA			;CHECK FOR DIGITS
	ADDI A,1-"0"(C)		;0 TO 9 MAPS INTO 1 TO 12
	JRST ASCR1		;DO REST OF CHARACTERS

;GVALUE evaluates a symbol.
;
;Accepts:	A/	radix50 symbol
;		B/	0 or specific module name (also radix50)
;
;Returns+1:	symbol not defined
;	+2:	A/	value of symbol
;		B/	location of value in symbol table, or -1 if opcode

GVALUE:	STKVAR <FINALF,OPX,WS,GVTAD,MNAME,SPTR,SYMEN2,SAVVAL,SAVVAD>
	TXZ A,SCFLD		;CLEAR SYMBOL CODE FIELD
	MOVEM A,WS		;REMEMBER WHICH SYMBOL WE'RE LOOKING FOR
	MOVEM B,MNAME		;REMEMBER MODULE NAME
	CALL CHKSYM		;MAKE SURE SYMBOL TABLE O.K.
	MOVE B,MNAME
	JUMPE B,SYMV0		;IF NO PROGRAM NAME, SEARCH ENTIRE TABLE
	SETOM FINALF		;IF USING SPECIFIC MODULE NAME, THIS IS FINAL PASS
	MOVE C,NSYMS		;GET NUMBER OF SYMBOLS
	LSH C,1			;FIND END OF SYMBOL TABLE
	ADD C,SYMBEG
	SUBI C,2		;GET TO FIRST POSSIBLE NAME PAIR
	MOVEM C,SPTR		;REMEMBER POINTER INTO SYMBOL TABLE
SYMV2:	MOVE A,SPTR		;GET POINTER INTO SYMBOL TABLE
	CAMGE A,SYMBEG		;IS MODULE NAME IN THE TABLE?
	JRST SYMVNO		;MODULE NOT FOUND
	CALL GETSYM		;GET NAME AND VALUE
	HLRE D,B		;GET NEGATIVE SIZE OF THIS PORTION
	CAMN A,MNAME		;HAVE WE FOUND THE CORRECT PROGRAM NAME YET?
	JRST [	MOVE C,SPTR	;YES, GET ADDRESS OF PROG NAME IN MEMORY
		JRST SYMV3]
	ADDM D,SPTR		;JUMP TO NEXT PORTION
	JRST SYMV2		;KEEP SEARCHING FOR MODULE

SYMV0:	SETZM FINALF		;SAY NO MODULE SUPPLIED, SO THIS ISN'T NECESSARILY FINAL PASS
	SKIPN A,LASTP		;GET LAST PROGRAM NAME IN WHICH SYMBOL WAS FOUND
	JRST SYMV4		;NONE, SO SEARCH ENTIRE TABLE
	CALL GETSYM		;GET INFO FROM SYMBOL TABLE
	HLRE D,B		;GET NEGATIVE SIZE OF THIS PORTION
	MOVE C,LASTP
SYMV3:	ADDI C,2
	ADD C,D			;GET STARTING ADDRESS OF TABLE FOR THIS MODULE
	MOVEM C,GVTAD		;REMEMBER BASE
	MOVN D,D		;GET POSITIVE NUMBER OF WORDS
	JRST SYMV5		;GO SEARCH FOR SYMBOL

SYMV4:	MOVE D,NSYMS		;GET NUMBER OF SYMBOLS TO SEARCH
	SETOM FINALF		;NO PREVIOUS PROGRAM, SO THIS IS FINAL PASS
	MOVE A,SYMBEG
	MOVEM A,GVTAD		;USE ENTIRE TABLE
	LSH D,1			;COMPUTE NUMBER OF WORDS OF SYMBOL TABLE PORTION
SYMV5:	ADD D,GVTAD		;COMPUTE ADDRESS ONE TOO LARGE FOR SEGMENT
	SOJ D,			;COMPUTE LARGEST ADDRESS IN SEGMENT
	MOVEM D,SYMEN2		;REMEMBER LARGEST ADDRESS
SYMV1:	MOVE A,GVTAD		;GET NEXT ADDRESS TO EXAMINE
	CAML A,SYMEN2		;MORE TO LOOK AT?
	JRST SYMVNO		;NO
	CALL GETSYM		;GET NAME AND VALUE FROM SYMBOL TABLE
	LOAD D,SNFLD,A		;GET NAME OF SYMBOL
	CAME D,WS		;IS THIS SYMBOL THE RIGHT NAME?
	JRST [	MOVEI A,2
		ADDM A,GVTAD	;ADVANCE TO NEXT SYMBOL IN TABLE
		JRST SYMV1]
	MOVEM B,SAVVAL		;SAVE THE VALUE OF THE SYMBOL
	MOVE A,GVTAD		;GET ADDRESS
	MOVEM A,SAVVAD		;REMEMBER IT TOO
GN:	MOVEI A,2
	ADDB A,GVTAD		;LOOK FOR PROGRAM NAME FOR THIS SYMBOL
	CALL GETSYM
	TXNE A,SCFLD		;FIND PROGRAM NAME YET?
	JRST GN			;NO, THERE'S GOT TO BE ONE!
	MOVE A,GVTAD
	MOVEM A,LASTP		;REMEMBER LOCATION OF PROGRAM NAME
	MOVE A,SAVVAL		;RETURN VALUE OF SYMBOL
	MOVE B,SAVVAD		;RETURN ADDRESS OF SYMBOL INFO
	RETSKP			;GIVE SUCCESS RETURN

;COME HERE WHEN SYMBOL ISN'T FOUND.  FINALF WILL BE -1 IF WE SHOULDN'T
;TRY ANY MORE TRICKS.  IF FINALF IS 0, THEN THIS FAILURE ONLY MEANS THAT
;THE CALLER DIDN'T SUPPLY A SPECIFIC MODULE NAME TO SEARCH AND WE COULDN'T
;FIND THE SYMBOL IN THE MODULE IN WHICH THE LAST SYMBOL WAS FOUND.  HENCE
;WE SHOULD NOW SEARCH THE ENTIRE TABLE.

SYMVNO:	SKIPN FINALF		;IS THIS THE FINAL PASS THAT FAILED?
	JRST SYMV4		;NO, GO SEARCH ENTIRE SYMBOL TABLE THIS TIME
	MOVEI A,1000		;NUMBER OF OPCODES TO TRY
	MOVEM A,OPX
TRYO1:	SOSGE A,OPX		;MORE OPCODES TO TRY?
	RET			;NO, SYMBOL DEFINITELY NOT FOUND
	LOAD A,OP%NAM,OPLIST(A)	;YES, GET NAME INFO
	JUMPE A,TRYO1		;SKIP THIS ONE IF HAS NO NAME
	ADD A,[440700,,1]	;MAKE BYTE POINTER TO ASCII NAME
	CALL ASCR50		;CHANGE ASCII TO RADIX50
	CAME A,WS		;IS THIS THE OPCODE WE'RE LOOKING FOR?
	JRST TRYO1		;NO, KEEP LOOKING
	MOVE A,OPX		;YES, GET OPCODE
	HRROI B,-1		;GIVE -1 TO SIGNIFY OPCODE
	LSH A,33		;MAKE INTO REAL OPCODE
	RETSKP			;GIVE SUCCESS RETURN

;GETSYM reads symbol info from the symbol table
;
;Accepts:	A/	symbol table address to read
;
;Returns+1:	A/	name of symbol
;		B/	value of symbol
;
;WARNING:	Since this routine uses the address as the small page for
;		mapping, it is only efficient if the symbol table is scanned
;		from small to large addresses!

GETSYM:	CAML A,SYMBA		;IS ADDRESS SMALLER THAN SMALLEST MAPPED?
	CAMLE A,SYMEA		;NO, WITHIN RANGE OF MAPPING?
	JRST GETS1		;NO, NEED TO MAP A DIFFERENT PART.
	DMOVE A,@SOFF		;YES, GET DATA Q-U-I-C-K-L-Y!
	RET

GETS1:	STKVAR <WA1>
	MOVEM A,WA1		;REMEMBER WHAT ADDRESS WE WANT TO READ
	MOVE B,A		;GET COPY OF ADDRESS
	TXZ B,777		;GET FIRST ADDRESS BEING MAPPED IN
	MOVEM B,SYMBA		;REMEMBER FIRST ADDRESS BEING MAPPED
	MOVN B,B		;CALCULATE OFFSET FOR INDEXING
	ADD B,SYMBF		;COMPLETE OFFSET
	HRLI B,A		;PREPARE FOR INDEXING BY REGISTER A
	MOVEM B,SOFF
	LSH A,-9		;GET PAGE NUMBER WE'LL MAP IN
	HRL A,FORK		;SAY WHICH FORK TO MAP FROM
	LDB B,[111100,,SYMBF]	;GET PAGE NUMBER OF SYMBOL BUFFER
	HRLI B,.FHSLF		;MAPPING INTO OURSELF
	MOVX C,PM%RD!PM%CNT!NSMPGS	;READ ACCESS, NUMBER OF SYMBOL PAGES WE HAVE ROOM FOR
	PMAP			;ESTABLISH NEW WINDOW INTO SYMBOL TABLE
	MOVE A,SYMBA		;GET SMALLEST ADDRESS THAT IS MAPPED
	ADDI A,-1+NSMPGS*1000	;CALCULATE LARGEST ADDRESS MAPPED
	MOVEM A,SYMEA		;REMEMBER IT
	MOVE A,WA1		;TRY AGAIN NOW THAT CORRECT CORRECT MAPPING ESTABLISHED
	JRST GETSYM

;TYPAAC types address and contents.
;
;Accepts:	A/	address

TYPAAC:	STKVAR <REMA>
	MOVEM A,REMA		;REMEMBER ADDRESS
	CALL TYPADD		;TYPE ADDRESS
	TYPE </   >		;PUT SLASH AND THREE SPACES AFTER ADDRESS
	MOVE A,REMA		;GET ADDRESS AGAIN
	CALL RANDOM		;READ CONTENTS
	 JRST [	TYPE <?>	;IF NO CONTENTS, TYPE QUESTION MARK
		RET]
	CALLRET TYPEXP		;TYPE EXPRESSION SYMBOLICALLY

;TYPADD types an address as name+n where name is the symbol who's value
;is closest to and less than or equal to the address, and n is the remainder.
;"+0" is not printed.
;
;Accepts:	A/	address

TYPADD::STKVAR <TYPVAL,TYPOFF>
	JUMPE A,[TYPE <0>	;HANDLE 0 SPECIALLY
		 RET]
	MOVEM A,TYPVAL		;REMEMBER VALUE
	CALL GNT		;GET LOCATION AND NAME OF NEAREST TAG
	SUB A,TYPVAL		;COMPUTE OFFSET
	MOVNM A,TYPOFF		;REMEMBER POSITIVE OFFSET
	CAMLE A,[-1000]		;IF OFFSET 1000 OR MORE, DON'T USE IT
	SKIPN A,B		;GET NAME OF SYMBOL
	JRST [	MOVE A,TYPVAL	;NO SYMBOL, SO JUST TYPE VALUE
		ETYPE <%1O>
		RET]
	CALL TYPSYM		;TYPE SYMBOL NAME
	SKIPN A,TYPOFF		;IS THERE AN OFFSET?
	RET			;NO, SO WE'RE DONE
	TYPE <+>		;YES, SO PUT IN PLUS SIGN
	ETYPE <%1O>		;PRINT OCTAL OFFSET
	RET			;DONE

;TYPEXP types out an expression symbolically.
;
;Accepts:	A/	expression

TYPEXP::STKVAR <WINS>
	JUMPE A,[TYPE <0>
		 RET]
	MOVEM A,WINS
	CALL GNT		;FIRST ATTEMPT EXACT MATCH
	CAMN A,WINS		;IS THERE AN EXACT MATCH?
	JRST [	MOVE A,B	;YES, GET NAME
		CALLRET TYPSYM]	;TYPE NAME AND RETURN
	MOVE A,WINS
	CALL TYPOP		;TYPE THE OPCODE
	JUMPE A,TYPHVS		;GO TYPE IN HALFWORDS IF NO OPCODE AT ALL
	TYPE < >		;ALWAYS PUT SPACE AFTER OPCODE
	TXNE A,ACFLD		;ANY AC FIELD INCLUDED IN OPCODE DEFINITION?
	JRST TYPNAC		;YES, SO DON'T ATTEMPT TO PRINT ANOTHER ONE
	LOAD A,ACFLD,WINS	;GET AC FIELD
	JUMPE A,TYPNAC		;MAYBE NO AC FIELD TO TYPE
	CALL SMORNM		;TYPE SYMBOL OR NUMBER
	TYPE <,>		;PUT COMMA AFTER AC FIELD
TYPNAC:	LOAD A,INDFLD,WINS	;GET INDIRECT BIT
	CAIE A,0		;ANY INDIRECT?
	TYPE <@>		;YES, DENOTE IT
	LOAD A,YFLD,WINS	;GET Y FIELD
	CALL TYPADD		;TYPE Y FIELD SYMBOLICALLY
	LOAD A,XFLD,WINS	;GET INDEX FIELD
	JUMPE A,R		;DONE IF NONE
	TYPE <(>
	CALL SMORNM		;TYPE INDEX FIELD
	TYPE <)>
	RET

;HERE WHEN NO OPCODE WAS FOUND SO WE WANT TO PRINT HALFWORDS.

TYPHVS:	HLRZ A,WINS		;GET LEFT HALF OF EXPRESSION
	JUMPE A,TYPHV1		;IF 0, DON'T PRINT IT OR COMMAS
	CALL TYPADD		;TYPE AS AN ADDRESS
	TYPE <,,>		;DENOTE HALFWORDS
TYPHV1:	HRRZ A,WINS		;GET RIGHT HALF OF EXPRESSION
	CALLRET TYPADD		;TYPE IT EVEN IF IT'S 0

;TYPSYM types out a symbol name.
;
;Accepts:	A/	radix50 symbol name

TYPSYM:	CALL R50TAS		;CHANGE TO ASCII
	UTYPE A			;TYPE ASCII SYMBOL
	RET			;DONE

;ROUTINE CHANGING RADIX50 IN A TO ASCIZ IN A AND B

R50TAS:	TLZ A,740000		;CLEAR JUNK PART
	MOVE D,[440700,,A]	;MAKE ASCIZ POINTER
	CALL R50OUL		;DO THE SYMBOL
	MOVEI C,0		;END WITH NULL
	IDPB C,D
	RET			;DONE

R50OUL:	IDIVI A,50		;GET A DIGIT SPLIT OFF
	JUMPE A,R50FIN		;DONE IF HAVE A ZERO
	HRLM B,(P)		;NO, SAVE THIS DIGIT
	CALL R50OUL		;AND LOOP
	HLRZ B,(P)		;GET BACK SAVED DIGIT
R50FIN:	MOVEI C," "		;IF NOTHING ELSE SET FOR SPACE
	CAIN B,47		;CODE FOR PERCENT SIGN?
	MOVEI C,"%"		;YES, GET IT
	CAIN B,46		;CODE FOR A DOLLAR SIGN?
	MOVEI C,"$"		;YES, GET IT
	CAIN B,45		;CODE FOR A PERIOD?
	MOVEI C,"."		;YES, GET IT
	CAIL B,13		;IN RANGE OF A LETTER?
	CAILE B,44		;WELL?
	SKIPA 			;NO
	MOVEI C,"A"-13(B)	;YES, GET IT
	CAIGE B,13		;FINALLY, IN RANGE OF A NUMBER?
	MOVEI C,"0"-1(B)	;YES, GET IT
	IDPB C,D		;OUTPUT THE CHAR
	RET			;AND RETURN

;TYPOP types out an opcode symbolically.  If the opcode has no symbol,
;then TYPOP gives a nonskip.
;
;Accepts:	A/	entire expression
;
;Returns+1:	A/	nonzero in fields that were printed

TYPOP:	STKVAR <WOP,XOPCOD>
	MOVEM A,WOP		;REMEMBER WHICH OPCODE
	TXZ A,INDFLD!XFLD!YFLD	;FIRST SEE IF THERE'S A SPECIAL OPCODE
	MOVEM A,XOPCOD		;REMEMBER EXTENDED OPCODE VALUE
	JUMPE A,TYPOP3		;DON'T ATTEMPT 0 OPCODE
	CALL GNT		;SEE WHAT SYMBOL MATCHES
	CAMN A,XOPCOD		;IS THERE A SPECIAL OPCODE?
	JRST TYPOP1		;YES, GO HANDLE IT
TYPOP3:	LOAD A,OPFLD,WOP	;NO SPECIAL OPCODE, GET REAL OPCODE
	LOAD A,OP%NAM,OPLIST(A)	;GET ADDRESS OF SYMBOL
	JUMPE A,R		;IF ZERO SAY THAT NOTHING WAS PRINTED
	ADD A,[440700,,1]	;MAKE BYTE POINTER AND SKIP VALUE
	ETYPE <%1M>		;TYPE THE SYMBOL
	JRST TYPOP2		;SAY ONLY OPCODE FIELD PRINTED

TYPOP1:	MOVE A,B		;PUT NAME OF EXTENDED OPCODE IN A
	CALL TYPSYM		;TYPE THE OPCODE
	MOVE A,XOPCOD		;GET VALUE OF OPCODE TYPED
	TXNE A,ACFLD		;DID OPCODE INCLUDE AN AC FIELD?
	JRST [	MOVX A,FLD(1,OPFLD)!FLD(1,ACFLD) ;YES, DENOTE THAT THESE FIELDS WERE PRINTED
		RET]
TYPOP2:	MOVX A,FLD(1,OPFLD)	;ONLY OPCODE FIELD PRINTED, SO MARK
	RET

;CHKSYM UPDATES SYMBOL TABLE DATABASE IF IT NEEDS IT

CHKSYM:	SKIPE SYMOKF		;IS SYMBOL DATABASE OK?
	RET			;YES, SO NOTHING TO DO
	STKVAR <INSYMP>
	SETZM LASTP		;NO CACHED PROGRAM NAME YET
	MOVEI A,JOBSYM		;POINT TO SYMBOL TABLE POINTER
	CALL RANDOM		;READ SYMBOL TABLE POINTER
	 JRST [	MOVEI A,0	;ASSUME 0
		JRST .+1]
	MOVEM A,INSYMP		;REMEMBER POINTER
	HRRZM A,SYMBEG		;REMEMBER WHERE SYMBOL TABLE BEGINS
	HLRE D,A		;GET NEGATIVE SIZE OF SYMBOL TABLE
	LDB A,[111100,,A]	;GET FIRST PAGE NUMBER OF SYMBOL TABLE
	MOVN B,D		;GET POSITIVE NUMBER OF WORDS
	LSH B,-1		;GET NUMBER OF SYMBOLS
	MOVEM B,NSYMS		;REMEMBER HOW MANY SYMBOLS
	HRRZ C,INSYMP		;GET FIRST WORD USED BY SYMBOL TABLE
	SUB C,D			;GET ADDRESS BEYOND SYMBOL TABLE
	SOJ C,			;GET LAST ADDRESS OF SYMBOL TABLE
	MOVEM C,SYMEND		;REMEMBER WHERE SYMBOL TABLE ENDS (AT -1 IF NO SYMBOLS!)
	SETOM SYMEA		;GUARANTEE THAT FIRST PROBE IS OUT OF RANGE
	SETOM SYMOKF		;SAY SYMBOLS ARE OK NOW
	RET

;OPLIST IS A LIST OF OPCODES.  THE LIST IS INDEXED BY OPCODE.

DEFINE INS(CODE,FLAGS)
<	FLAGS+[	CODE
		ASCIZ /CODE/]
>

OPLIST:	BLOCK 110		;INITIALLY, WE DON'T KNOW ABOUT THESE OPCODES
INS DFAD
INS DFSB
INS DFMP
INS DFDV
INS DADD
INS DSUB
INS DMUL
INS DDIV
INS DMOVE
INS DMOVN
INS FIX
INS EXTEND
INS DMOVEM
INS DMOVNM
INS FIXR
INS FLTR
INS UFA
INS DFN
INS FSC
INS IBP
INS ILDB
INS LDB
INS IDPB
INS DPB
INS FAD
INS FADL
INS FADM
INS FADB
INS FADR
INS FADRI
INS FADRM
INS FADRB
INS FSB
INS FSBL
INS FSBM
INS FSBB
INS FSBR
INS FSBRI
INS FSBRM
INS FSBRB
INS FMP
INS FMPL
INS FMPM
INS FMPB
INS FMPR
INS FMPRI
INS FMPRM
INS FMPRB
INS FDV
INS FDVL
INS FDVM
INS FDVB
INS FDVR
INS FDVRI
INS FDVRM
INS FDVRB
INS MOVE
INS MOVEI
INS MOVEM
INS MOVES
INS MOVS
INS MOVSI
INS MOVSM
INS MOVSS
INS MOVN
INS MOVNI
INS MOVNM
INS MOVNS
INS MOVM
INS MOVMI
INS MOVMM
INS MOVMS
INS IMUL
INS IMULI
INS IMULM
INS IMULB
INS MUL
INS MULI
INS MULM
INS MULB
INS IDIV
INS IDIVI
INS IDIVM
INS IDIVB
INS DIV
INS DIVI
INS DIVM
INS DIVB
INS ASH
INS ROT
INS LSH
INS JFFO,OP%TRN!OP%CB
INS ASHC
INS ROTC
INS LSHC
	0			;247 ISN'T USED.
INS EXCH
INS BLT
INS AOBJP,OP%TRN!OP%CB
INS AOBJN,OP%TRN!OP%CB
INS JRST,OP%TRN
INS JFCL
INS XCT
INS MAP
INS PUSHJ,OP%SC!OP%TRN
INS PUSH
INS POP
INS POPJ,OP%TRN!OP%RET
INS JSR,OP%TRN!OP%SC
INS JSP,OP%TRN!OP%SC
INS JSA,OP%TRN!OP%SC
INS JRA,OP%TRN!OP%RET
INS ADD
INS ADDI
INS ADDM
INS ADDB
INS SUB
INS SUBI
INS SUBM
INS SUBB
INS CAI
INS CAIL,OP%SKP
INS CAIE,OP%SKP
INS CAILE,OP%SKP
INS CAIA,OP%US
INS CAIGE,OP%SKP
INS CAIN,OP%SKP
INS CAIG,OP%SKP
INS CAM
INS CAML,OP%SKP
INS CAME,OP%SKP
INS CAMLE,OP%SKP
INS CAMA,OP%US
INS CAMGE,OP%SKP
INS CAMN,OP%SKP
INS CAMG,OP%SKP
INS JUMP
INS JUMPL,OP%TRN!OP%CB
INS JUMPE,OP%TRN!OP%CB
INS JUMPLE,OP%TRN!OP%CB
INS JUMPA,OP%TRN
INS JUMPGE,OP%TRN!OP%CB
INS JUMPN,OP%TRN!OP%CB
INS JUMPG,OP%TRN!OP%CB
INS SKIP
INS SKIPL,OP%SKP
INS SKIPE,OP%SKP
INS SKIPLE,OP%SKP
INS SKIPA,OP%US
INS SKIPGE,OP%SKP
INS SKIPN,OP%SKP
INS SKIPG,OP%SKP
INS AOJ
INS AOJL,OP%TRN!OP%CB
INS AOJE,OP%TRN!OP%CB
INS AOJLE,OP%TRN!OP%CB
INS AOJA,OP%TRN
INS AOJGE,OP%TRN!OP%CB
INS AOJN,OP%TRN!OP%CB
INS AOJG,OP%TRN!OP%CB
INS AOS
INS AOSL,OP%SKP
INS AOSE,OP%SKP
INS AOSLE,OP%SKP
INS AOSA,OP%US
INS AOSGE,OP%SKP
INS AOSN,OP%SKP
INS AOSG,OP%SKP
INS SOJ
INS SOJL,OP%TRN!OP%CB
INS SOJE,OP%TRN!OP%CB
INS SOJLE,OP%TRN!OP%CB
INS SOJA,OP%TRN
INS SOJGE,OP%TRN!OP%CB
INS SOJN,OP%TRN!OP%CB
INS SOJG,OP%TRN!OP%CB
INS SOS
INS SOSL,OP%SKP
INS SOSE,OP%SKP
INS SOSLE,OP%SKP
INS SOSA,OP%US
INS SOSGE,OP%SKP
INS SOSN,OP%SKP
INS SOSG,OP%SKP
INS SETZ
INS SETZI
INS SETZM
INS SETZB
INS AND
INS ANDI
INS ANDM
INS ANDB
INS ANDCA
INS ANDCAI
INS ANDCAM
INS ANDCAB
INS SETM
INS XMOVEI
INS SETMM
INS SETMB
INS ANDCM
INS ANDCMI
INS ANDCMM
INS ANDCMB
INS SETA
INS SETAI
INS SETAM
INS SETAB
INS XOR
INS XORI
INS XORM
INS XORB
INS IOR
INS IORI
INS IORM
INS IORB
INS ANDCB
INS ANDCBI
INS ANDCBM
INS ANDCBB
INS EQV
INS EQVI
INS EQVM
INS EQVB
INS SETCA
INS SETCAI
INS SETCAM
INS SETCAB
INS ORCA
INS ORCAI
INS ORCAM
INS ORCAB
INS SETCM
INS SETCMI
INS SETCMM
INS SETCMB
INS ORCM
INS ORCMI
INS ORCMM
INS ORCMB
INS ORCB
INS ORCBI
INS ORCBM
INS ORCBB
INS SETO
INS SETOI
INS SETOM
INS SETOB
INS HLL
INS XHLLI
INS HLLM
INS HLLS
INS HRL
INS HRLI
INS HRLM
INS HRLS
INS HLLZ
INS HLLZI
INS HLLZM
INS HLLZS
INS HRLZ
INS HRLZI
INS HRLZM
INS HRLZS
INS HLLO
INS HLLOI
INS HLLOM
INS HLLOS
INS HRLO
INS HRLOI
INS HRLOM
INS HRLOS
INS HLLE
INS HLLEI
INS HLLEM
INS HLLES
INS HRLE
INS HRLEI
INS HRLEM
INS HRLES
INS HRR
INS HRRI
INS HRRM
INS HRRS
INS HLR
INS HLRI
INS HLRM
INS HLRS
INS HRRZ
INS HRRZI
INS HRRZM
INS HRRZS
INS HLRZ
INS HLRZI
INS HLRZM
INS HLRZS
INS HRRO
INS HRROI
INS HRROM
INS HRROS
INS HLRO
INS HLROI
INS HLROM
INS HLROS
INS HRRE
INS HRREI
INS HRREM
INS HRRES
INS HLRE
INS HLREI
INS HLREM
INS HLRES
INS TRN
INS TLN
INS TRNE,OP%SKP
INS TLNE,OP%SKP
INS TRNA,OP%US
INS TLNA,OP%US
INS TRNN,OP%SKP
INS TLNN,OP%SKP
INS TDN
INS TSN
INS TDNE,OP%SKP
INS TSNE,OP%SKP
INS TDNA,OP%US
INS TSNA,OP%US
INS TDNN,OP%SKP
INS TSNN,OP%SKP
INS TRZ
INS TLZ
INS TRZE,OP%SKP
INS TLZE,OP%SKP
INS TRZA,OP%US
INS TLZA,OP%US
INS TRZN,OP%SKP
INS TLZN,OP%SKP
INS TDZ
INS TSZ
INS TDZE,OP%SKP
INS TSZE,OP%SKP
INS TDZA,OP%US
INS TSZA,OP%US
INS TDZN,OP%SKP
INS TSZN,OP%SKP
INS TRC
INS TLC
INS TRCE,OP%SKP
INS TLCE,OP%SKP
INS TRCA,OP%US
INS TLCA,OP%US
INS TRCN,OP%SKP
INS TLCN,OP%SKP
INS TDC
INS TSC
INS TDCE,OP%SKP
INS TSCE,OP%SKP
INS TDCA,OP%US
INS TSCA,OP%US
INS TDCN,OP%SKP
INS TSCN,OP%SKP
INS TRO
INS TLO
INS TROE,OP%SKP
INS TLOE,OP%SKP
INS TROA,OP%US
INS TLOA,OP%US
INS TRON,OP%SKP
INS TLON,OP%SKP
INS TDO
INS TSO
INS TDOE,OP%SKP
INS TSOE,OP%SKP
INS TDOA,OP%US
INS TSOA,OP%US
INS TDON,OP%SKP
INS TSON,OP%SKP
	BLOCK 100		;OPCODES 700 THROUGH 777 AREN'T USED
SUBTTL Symbolic expression parsing

;GINSTR gets an instruction
;
;Returns+1:	parse failure
;Returns+2:	A/	value of expression

GINSTR::CALL RINST		;READ IN THE EXPRESSION
	CALLRET PINST		;PARSE IT AND RETURN

;RINST reads a symbolic instruction.  It is stored in free space.
;
;Accepts:	A/	0 or pointer to guideword string (needed to allow "@FOO")
;
;Returns+1:	A/	address of list of addresses of asciz parts

RINST::	TRVAR <ESCFLG,OPPTR,ACPTR,INDPTR,XPTR,YPTR>
	SETZM ESCFLG		;NO ESCAPE SEEN YET
	MOVEM A,.CMDAT+FBLOCK	;PREPARE TO DO GUIDEWORDS
	MOVX B,CMNOI		;SPECIFY NOISE FUNCTION
	MOVEM B,.CMFNP+FBLOCK
	MOVEI B,FBLOCK		;SAY WHERE FUNCTION BLOCK IS
	JUMPE A,RIN1		;SKIP NOISE IF NONE
	CALL XSKP		;DO SPECIAL NOISE
	 CMERRX			;IF WRONG GUIDEWORDS, SAY SO
RIN1:	SETZM ESCFLG		;CLEAR THIS AGAIN, SINCE NOISE TURNED IT ON!
	SETZM ACPTR		;NO AC FIELD YET
	SETZM XPTR		;NO INDEX FIELD YET
	SETZM INDPTR		;NO INDIRECT YET
	CALL RSYM		;READ THE OPCODE
	 JRST NOOPC		;GO HANDLE CASE OF NO OPCODE
	CALL BUFFF		;GET POINTER TO OPCODE
	MOVEM A,OPPTR		;REMEMBER POINTER TO OPCODE
	CALL RSPACE		;READ SPACE AFTER OPCODE
	 JFCL			;DON'T CARE IF IT'S NOT THERE.
	CALL RSYM		;READ AC FIELD
	 JRST OPNOAC		;GO HANDLE OPCODE BUT NO AC FIELD
	CALL BUFFF		;GET POINTER TO ADDRESS
	MOVEM A,ACPTR
	CALL RCMA		;SEE IF "FOO,"
	 JRST OANC		;GO HANDLE OPCODE AC BUT NO COMMA
SCOMA:	CALL RIND		;SEE IF INDIRECT NEXT
	 JRST HINO		;NO
HI:	HRROI A,[ASCIZ /1/]
	CALL BUFFS		;GET POINTER TO VALUE OF 1 FOR INDIRECT
	MOVEM A,INDPTR		;REMEMBER POINTER
HINO:	SETZM YPTR		;FIRST ASSUME NO Y FIELD
	CALL RSYM		;SEE IF ONE THERE
	 JRST HXM
	CALL BUFFF		;YES, GET POINTER TO IT
	MOVEM A,YPTR		;REMEMBER POINTER TO IT
HXM:	CALL LPAREN		;READ OPEN PAREN
	 JRST IALL		;NO INDEX FIELD
HP:	CALL RSYM		;READ INDEX REGISTER NAME
	 CMERRX <Invalid index register>
	CALL BUFFF
	MOVE D,A		;STORE NEW PART OF STRING
	MOVE A,CSBUFP		;POINT TO SOME SCRATCH SPACE
	MOVE B,XPTR		;GET POSSIBLE "FOO" FROM "FOO,,"
	MOVEI C,.CHNUL		;STOP ON NULL
	SOUT			;GET  "FOO" FROM "FOO,,"
	MOVEI B,"+"
	BOUT
	MOVE B,D
	SOUT			;MAKE INDEX FIELD "FOO+ZOT" IF INPUT WAS
				;"FOO,,Y(ZOT)"
	MOVE A,CSBUFP		;POINT TO BEGINNING OF SCRATCH SPACE AGAIN
	CALL BUFFS		;BUFFER THE STRING
	MOVEM A,XPTR		;STORE NEW POINTER TO INDEX FIELD
	MOVEM A,XPTR		;REMEMBER POINTER TO INDEX FIELD
	MOVEI B,[FLDDB. .CMTOK,CM%SDH,<-1,,[ASCIZ /)/]>,<Right parenthesis to end index register>]
	CALL FLDSKP
	 CMERRX <Missing right parenthesis after index register>
IALL:	MOVEI A,5
	CALL GETBUF		;GET BUFFER FOR CONSTITUENTS OF INSTRUCTION
	MOVE B,OPPTR
	MOVEM B,(A)		;STORE POINTERS TO PARTS IN BUFFER
	MOVE B,ACPTR
	MOVEM B,1(A)		;OPCODE
	MOVE B,INDPTR		;INDIRECT
	MOVEM B,2(A)
	MOVE B,YPTR
	MOVEM B,3(A)		;Y FIELD
	MOVE B,XPTR
	MOVEM B,4(A)		;X FIELD
	RET			;RETURN WITH POINTER TO LIST OF CONSTITUENTS IN A

;RCMA, RIND, LPAREN ETC.  ALL ATTEMPT TO READ TOKENS SUCH AS COMMA, ATSIGN,
;LEFT PARENTHESIS, SKIPPING IF THE TOKEN IS SEEN.

RCMA:	MOVEI B,[FLDDB. .CMTOK,CM%SDH,<-1,,[ASCIZ /,/]>,<Comma>]
R11:	CALLRET XSKP		;PARSE THE TOKEN; GIVE SKIP OR ERROR RETURN

RIND:	MOVEI B,[FLDDB. .CMTOK,CM%SDH,<-1,,[ASCIZ /@/]>,<Atsign (@)>]
	JRST R11

LPAREN:	CALL RSPACE		;IS SPACE NEXT?
	 SKIPA B,[[FLDDB. .CMTOK,CM%SDH,<-1,,[ASCIZ /(/]>,<Left parenthesis>]]
	RET			;YES, SO THERE'S NO PARENTHESIS (OTHER THAN PERHAPS GUIDE WORDS)
	JRST R11		;NO

RSPACE:	MOVEI B,[FLDDB. .CMTOK,CM%SDH,<-1,,[ASCIZ / /]>,<Space>]
	JRST R11

;"FOO FOO" HAS BEEN SEEN, BUT IT'S NOT "FOO FOO,".
;IT'S EITHER "FOO FOO(" OR JUST "FOO FOO".

OANC:	MOVE A,ACPTR
	MOVEM A,YPTR		;THAT AC IS REALLY A Y FIELD
	SETZM ACPTR		;NO AC FIELD ANYMORE
	JRST HXM		;GO SEE IF PARENTHESES COMING

;NO OPCODE WAS SEEN, I.E. NO SYMBOL.

NOOPC:	SETZM OPPTR		;IF NO SYMBOL FIRST, NO OPCODE OR AC FIELD
	CALL RIND		;SEE IF EXPRESSION STARTS WITH ATSIGN
	 JRST [	CALL RCMA	;NO, TRY COMMA
		 JRST [	CALL LPAREN	;NO, TRY PARENTHESIS
			 CMERRX <No opcode seen, and no comma (,) atsign (@) or parenthesis seen either>
			SETZM YFLD	;NO Y FIELD
			JRST HP	]	;HANDLE PARENTHESES
		CALL RCMA	;SEE IF EXPRESSION STARTS WITH TWO COMMAS
		 JRST SCOMA	;",FOO" EQUALS ",,FOO"
		JRST SCOMA]
	JRST HI			;HANDLE INDIRECT

;COME HERE WHEN WE DIDN'T SEE "FOO FOO".  IT MUST THEREFORE BE "FOO," OR
;"FOO @" OR "FOO (" OR JUST "FOO".

OPNOAC:	CALL RIND			;TRY "FOO@"
	 JRST [	CALL RCMA		;NO, HOW ABOUT "FOO,"
		 JRST [	SETZM YPTR	;WE'LL USE OPCODE FOR Y FIELD
			CALL LPAREN	;HOW ABOUT "FOO("
			 JRST IALL	;IT'S JUST "FOO"
			JRST HP]	;IT'S JUST "FOO ("
		CALL RCMA		;IT'S "FOO,".  HOW ABOUT "FOO,,"
		 JRST [	MOVE A,OPPTR	;IT'S JUST "FOO,"
			MOVEM A,ACPTR	;SO OPCODE WAS REALLY AN ACCUMULATOR
			SETZM OPPTR	;SAY THERE'S NO OPCODE
			JRST SCOMA]	;HANDLE INDIRECT MAYBE
		MOVE A,OPPTR		;IT'S "FOO,,ZOT" SO "FOO" ISN'T
		MOVEM A,XPTR		;REALLY AN OPCODE
		SETZM OPPTR		;MARK THAT THERE'S NO OPCODE
		JRST SCOMA]
	JRST HI				;HANDLE INDIRECT

;RSYM reads a symbol name which may be preceded by a program name and
;and ampersand.  For instance, EXEC1&DELET3 means symbol DELET3 in module
;EXEC1.
;
;Returns+1:	null symbol encountered
;	+2:	real symbol encountered

RSYM:	MOVEI B,[FLDBK. .CMFLD,CM%SDH,,<Optional module name and "&", followed by symbol name>,,[BRMSK. FLDB0.,FLDB1.,FLDB2.,FLDB3.,<+-*/&.$%>]]
	CALL XSKP		;READ SYMBOL NAME
	 JRST RSYM1		;NOT A REAL SYMBOL, TRY A FAKE ONE
	LDB A,[350700,,ATMBUF]	;GET FIRST CHARACTER OF SYMBOL READ
	CAIE A,0		;IF NOTHING READ, DON'T SKIP YET
	RETSKP
RSYM1:	MOVEI B,[FLDDB. .CMTOK,CM%SDH,<-1,,[ASCIZ /[\]/]>,<"[\]" to stand for literal>]
	CALLRET XSKP		;IS SPECIAL LITERAL BEING TYPED (SKIP IF YES)?

;XSKP is exactly like SKPFLD, except "@" is allowed as a regular input
;character instead of as an indirect indication
;
;The purpose of ESCFLG is so if the user is typing something like
;
;	DEPOSIT FOO (CONTENTS) ZOT
;
;and types escape after "FOO", we want the guide words "(CONTENTS)" to appear
;instead of waiting to see if the user is going to follow FOO with something,
;such as in "DEPOSIT FOO,,BLECCH (CONTENTS) ZOT", which is a less likely input.

XSKP:	SKIPE ESCFLG		;USER TYPED ESCAPE TO GET TO NEXT FIELD?
	RET			;YES, SO GIVE FAILURE TO EVERYTHING
	CALL CFIELD		;READ THE FIELD
	TXNE A,CM%NOP		;SUCCEEDED?
	 RET			;NO, GIVE FAILURE RETURN
	CALL NESC		;USER TYPE ESCAPE?
	 SETOM ESCFLG		;YES, REMEMBER.
	RETSKP			;SAY SUCCESS

;ROUTINE TO EVALUATE AN EXPRESSION IN THE ATOM BUFFER, AND RETURN THE
;ASSEMBLED CODE IN THE CODE AREA.  AN EXPRESSION IS MADE UP OF CONSTANTS
;AND SYMBOLS, RELATED IN THE USUAL WAY WITH PLUS, MINUS, MULTIPLY, DIVIDE,
;EXPONENTIATION, AND PARANTHESIS SYMBOLS.

;EVAL evaluates an expression.
;
;Accepts:	A/	pointer to expression
;Returns+1:	there was an undefined symbol somewhere
;	+2:	A/	value of expression

CODSIZ==20
DATSIZ==20
EVAL::	SAVEAC <P1>		;WE NEED A PERMANENT AC
	TRVAR <DATPTR,<DATA,DATSIZ>,<SYMBUF,CODSIZ>,<CODE,CODSIZ>,INPTR,RFLAG,EVERRF>
	SETZM EVERRF		;NO UNDEFINED SYMBOL SEEN YET
	SETOM DATPTR		;PREPARE TO USE FIRST WORD OF DATA AREA
	CALL FIXPT		;HANDLE -1 IN LEFT HALF
	MOVEM A,INPTR		;INITIALIZE THE POINTER
	MOVE P1,[IOWD CODSIZ,1]	;SET UP CODE GENERATION POINTER
	ADDI P1,-1+CODE
	SETZM	RFLAG		;NO RESCANNING OF CHARACTERS YET
	CALL	EXPR		;READ IN AN EXPRESSION
	CALL CHRIN		;READ TERMINATING CHARACTER
	SKIPE	C		;MAKE SURE FIELD IS DONE
PARBAD:	 ERROR <Illegal expression typed>
	PUSH P1,[RET]		;COMPLETE SUBROUTINE
	SKIPE EVERRF		;UNDEFINED SYMBOL?
	RET			;YES, NONSKIP RETURN
	CALL CODE		;EXECUTE THE COMPILED EXPRESSION
	RETSKP			;RETURN WITH ANSWER IN A

;HERE TO PARSE AN EXPRESSION.  GENERATED CODE WILL RETURN ANSWER IN A.

EXPR:	CALL CHRIN		;READ FIRST CHARACTER
	CAIN C,"+"		;PLUS SIGN?
	JRST	EXPPOS		;YES, GO ON
	CAIN C,"-"		;MINUS SIGN?
	JRST	EXPNEG		;YES, GO GET NEGATIVE TERM
	SETOM RFLAG		;NO, PUT BACK THE CHARACTER
EXPPOS:	CALL	TERM		;READ IN THE TERM
EXPNXT:	CALL CHRIN		;THEN GET NEXT CHARACTER
	CAIN C,"+"		;WANTS TO ADD ANOTHER TERM?
	JRST	EXPRAD		;YES, GO DO IT
	CAIN C,"-"		;WANTS TO SUBTRACT A TERM?
	JRST	EXPRSB		;YES, GO DO IT
	SETOM RFLAG		;NONE OF THEM, RESTORE CHAR
	RET			;AND DONE


EXPNEG:	CALL	TERM		;COLLECT A TERM
	PUSH P1,[MOVNS A]	;NEGATE IT
	JRST	EXPNXT		;AND LOOK FOR ANOTHER TO ADD TO IT

EXPRAD:	PUSH P1,[PUSH P,A]	;SAVE CURRENT VALUE
	CALL	TERM		;COLLECT TERM TO ADD
	PUSH P1,[POP P,B]	;RESTORE VALUE
	PUSH P1,[ADD A,B]	;AND ADD TOGETHER
	JRST	EXPNXT		;LOOK FOR ANOTHER

EXPRSB:	PUSH P1,[PUSH P,A]	;SAVE CURRENT VALUE
	CALL	TERM		;COLLECT TERM TO SUBTRACT
	PUSH P1,[POP P,B]	;RESTORE VALUE
	PUSH P1,[SUBM B,A]	;DO THE SUBTRACTION
	JRST	EXPNXT		;LOOP
;HERE TO PARSE A TERM.  GENERATED CODE RETURNS ANSWER IN A.


TERM:	CALL	FACTOR		;READ IN A FACTOR
TRMNXT:	CALL CHRIN		;GET TERMINATOR
	CAIN C,"*"		;MULTIPLICATION SIGN?
	JRST	TERMML		;YES, GET ANOTHER FACTOR
	CAIN C,"/"		;DIVISION SIGN?
	JRST	TERMDV		;YES, ALSO GET A FACTOR
	SETOM RFLAG		;NO, RESTORE CHAR
	RET			;DONE


TERMML:	PUSH P1,[PUSH	P,A]	;SAVE VALUE
	CALL	FACTOR		;READ IN ANOTHER FACTOR
	PUSH P1,[POP P,B]	;RESTORE OLD VALUE
	PUSH P1,[IMUL A,B]	;DO THE MULTIPLY
	JRST	TRMNXT		;AND LOOK FOR MORE

TERMDV:	PUSH P1,[PUSH P,A]	;SAVE VALUE
	CALL	FACTOR		;READ IN ANOTHER FACTOR
	PUSH P1,[POP P,B]	;RESTORE OLD VALUE
	PUSH P1,[IDIVM B,A]	;DO THE DIVIDE
	JRST	TRMNXT		;AND LOOK FOR MORE
;HERE TO PARSE A FACTOR.  CODE GENERATED RETURNS VALUE IN A.

FACTOR:	CALL	SUBFAC		;READ A SUB-FACTOR
	CALL CHRIN		;THEN READ NEXT CHARACTER
	CAIE C,"^"		;WANT TO DO EXPONENTIATION?
	JRST	RESCAN		;NO, RESTORE CHAR AND RETURN
	ERROR <We don't handle uparrow yet>

;HERE TO PARSE A SUB-FACTOR.  CODE GENERATED RETURNS VALUE IN A.

SUBFAC:	CALL	PARSYM		;LOOK FOR SYMBOL (AND LEAVE TERMINATOR IN C)
	SKIPE SYMBUF		;DID WE GET A SYMBOL?
	JRST ISSYM		;YES
	CAIN C,"("		;WANTS TO NEST AN EXPRESSION?
	JRST	ISEXPR		;YES, GO DO THAT
	CALL PARBAD		;OTHERWISE HAS TO BE AN ERROR

ISEXPR:	CALL CHRIN		;SKIP OVER THE PARENTHESIS
	CALL	EXPR		;COMPUTE THE NESTED EXPRESSION
	CALL CHRIN		;GET TERMINATOR
	CAIE C,")"		;CLOSING PARANTHESIS?
	CALLRET PARBAD		;NO, INVALID EXPRESSION
	RET			;O.K.
ISNUM:	TLCE A,-1		;SMALL NUMBER?
	JRST	ISNUM1		;NO, GO ON
	HRLI A,(MOVEI A,)	;YES, FINISH INSTRUCTION
	PUSH P1,A		;STORE IT
	RET			;DONE

ISNUM1:	TLCE A,-1		;LEFT HALF -1?
	JRST	ISNUM2		;NO, TRY OTHER STUFF
	TXO A,<HRROI A,>	;YES, FINISH IT
	PUSH P1,A		;STORE IT
	RET			;DONE

ISNUM2:	TRCE A,-1		;RIGHT HALF ZERO?
	JRST	ISNUM3		;NO, GO ON
	HLRZ A,A		;YES, GET VALUE
	TXO A,<MOVSI A,>	;FINISH INSTRUCTION
	PUSH P1,A		;STORE IT
	RET			;DONE

ISNUM3:	TRCE A,-1		;RIGHT HALF ONES?
	JRST	ISNUM4		;NO, HAVE TO DO HARD WAY
	HLRZ A,A		;YES, GET LEFT HALF
	TXO A,<HRLOI A,>	;FINISH INSTRUCTION
	PUSH P1,A		;SAVE IT
	RET			;DONE

ISNUM4:	AOS B,DATPTR		;ALLOCATE NEW DATA LOCATION
	CAIL B,DATSIZ		;MAKE SURE TABLE HAS ROOM
	 ERROR <Too many constants typed>
	ADDI B,DATA		;GET ADDRESS WHERE DATA GOES
	MOVEM A,(B)		;SAVE THE NUMBER
	TXO B,<MOVE A,>		;FINISH INSTRUCTION
	PUSH P1,B		;STORE IT
	RET			;DONE
ISSYM:	HRROI A,SYMBUF		;POINT TO MODULE AND SYMBOL PAIR
	CALL AVALUE		;GET VALUE OF SYMBOL AND LOCATION OF VALUE
	 JRST [	SETOM EVERRF	;SAY THERE IS AN EVALUATION ERROR
		RET]
	JUMPL B,ISNUM		;IF B NEGATIVE, IT'S A REAL NUMBER
	HRLI B,(<MOVEI A,>)	;MAKE INSTRUCTION TO LOAD UP SYMBOL INFO ADDRESS
	PUSH P1,B		;PUT LOAD INSTRUCTION ON STACK
	PUSH P1,[CALL GSX]	;PUT CALL FOR GETTING VALUE OF SYMBOL
	RET

;GSX is called by the compiled code to get the value of a symbol
;
;Accepts:	A/	address of symbol info
;
;Returns:	A/	value of symbol

GSX:	CALL GETSYM		;GET NAME AND VALUE
	MOVE A,B		;WE ONLY WANT VALUE
	RET

RESCAN:	SETOM RFLAG		;RESTORE CURRENT CHAR
	RET			;AND RETURN
;ROUTINE TO READ IN A SYMBOL NAME.  RETURNS asciz in SYMBUF.

PARSYM:	MOVE B,[POINT 7,SYMBUF]	;GET POINTER
	SETZM SYMBUF		;SO WE'LL KNOW IF NO SYMBOL GETS READ
SYMIN1:	CALL CHRIN		;GET CHARACTER
	CAIE C,"."		;DOTS CAN BE IN SYMBOLS
	CAIN C,"&"		;AMPERSAND MEANS MODULE NAME PRECEDES IT
	JRST SYMIN3
	CAIN C,"%"		;PERCENTS CAN BE IN SYMBOLS
	JRST SYMIN3
	CAIE C,"$"		;ALLOW DOLLAR SIGNS IN SYMBOL
	CAIL C,"0"		;CHECK FOR  DIGIT
	CAILE C,"9"		;IS IT?
SYMIN2:	CAIL C,"A"		;CHECK FOR LETTER
	CAILE C,"Z"		;IS IT?
	JRST [	MOVEI C,.CHNUL	;GUARANTEE NULL AFTER SYMBOL NAME
		IDPB C,B
		CALLRET RESCAN]
SYMIN3:	IDPB C,B		;INSERT THIS LETTER
	JRST SYMIN1		;GET MORE
;INPUT ROUTINE FOR THE CHARACTERS WE ARE PARSING.  LOWER CASE IS
;CONVERTED TO UPPER CASE, AND RESCANS OF THE LAST CHARACTER IS
;PROVIDED FOR.  CHARACTER RETURNED IN AC C.  A NULL INDICATES THE
;END OF THE ATOM BUFFER.

CHRIN:	AOSE	RFLAG		;WANT TO REREAD A CHAR?
	IBP	INPTR		;NO, ADVANCE POINTER
	LDB C,INPTR		;READ THE CHARACTER
	CAIN C,15		;CARRIAGE RETURN?
	JRST	CHRIN		;YES, EAT IT
	CAIL C,"A"+40		;LOWER CASE?
	CAILE C,"Z"+40		;WELL?
	RET			;NO, DONE
	SUBI C,40		;YES, CONVERT TO UPPER CASE
	RET			;RETURN

PINST::	TDZA B,B
PINSTX:	MOVEI B,1
;	CALLRET PINST0		;FALL INTO PINST0

;PINST0 parses a symbolic instruction.
;
;Accepts:	A/	address of list of pointers to consituents
;		B/	0 - don't allow "[\]" as special symbol
;			1 - allow "[\]" for a don't care field
;
;Returns+1:	can't parse (undefined symbol)
;	+2:	A/	value of instruction
;		B/	mask of do care fields, if 1 was given in call

PINST0:	TRVAR <LITF,INSVAL,AL,PERRF,INSMSK>
	MOVEM B,LITF		;REMEMBER WHETHER SPECIAL LITERAL ALLOWED
	SETOM INSMSK		;INITIALLY, WE CARE ABOUT ALL FIELDS
	SETZM PERRF		;NO ERROR YET
	SETZM INSVAL		;START WITH CLEAR INSTRUCTION
	MOVEM A,AL		;REMEMBER ADDRESS OF LIST
	MOVEI A,0
	MOVSI B,004400		;ACCUMULATE OPCODE INTO ENTIRE WORD
	CALL PPART		;PARSE OPCODE
	MOVEI A,1
	MOVSI B,270400		;PUT THIS IN AC FIELD
	CALL PPART		;GET AC FIELD
	MOVEI A,2
	MOVSI B,260100		;PUT INDIRECT IN INDIRECT BIT
	CALL PPART
	MOVEI A,3		;GET Y FIELD
	MOVSI B,002200		;Y FIELD
	CALL PPART
	MOVEI A,4
	MOVSI B,222200		;INDEX REGISTER FIELD (MIGHT BE MORE!)
	CALL PPART		;GET INDEX FIELD
	MOVE A,INSVAL
	MOVE B,INSMSK		;GIVE POSSIBLE MASK
	SKIPE PERRF		;ANY ERRORS?
	RET			;YES, GIVE NONSKIP
	RETSKP			;GIVE SUCCESS RETURN

PPART:	STKVAR <BP00>
	HRRI B,INSVAL		;MAKE COMPLETE BYTE POINTER
	MOVEM B,BP00		;REMEMBER BYTE POINTER
	ADD A,AL		;GET ADDRESS OF WORD CONTAINING POINTER
	SKIPN A,(A)		;GET POINTER
	RET			;NO POINTER, SO LEAVE FIELD ALONE
	SKIPE LITF		;SPECIAL LITERAL ALLOWED?
	JRST [	MOVE B,(A)	;YES, GET POSSIBLE SPECIAL LITERAL
		CAME B,[ASCII /[\]/]	;IS IT THE SPECIAL ONE?
		JRST .+1	;NO
		MOVEI B,0	;YES, GET 0 FOR THIS PART OF MASK
		MOVE A,BP00	;GET BYTE POINTER TO INSTRUCTION
		HRRI A,INSMSK	;MAKE IT POINT TO MASK
		DPB B,A		;CLEAR APPROPRIATE PART OF MASK
		RET]		;DONE
	CALL EVAL		;GET VALUE OF FIELD
	 SETOM PERRF		;COULDN'T, MARK AS ERROR
	LDB B,BP00		;GET POSSIBLE DATA
	ADD A,B			;ADD IN THE NEW (NEEDED FOR "FOO,,ZOT(3)")
	DPB A,BP00		;STORE RESULT IN APPROPRIATE FIELD
	RET

END