Trailing-Edge
-
PDP-10 Archives
-
bb-m081y-sm_t20_v7_0_03_exec_src_mod
-
exec/execp.mac
There are 47 other files named execp.mac in the archive. Click here to see a list.
; Edit= 4444 to EXECP.MAC on 21-May-90 by GSCOTT
;Make sure UFORK set up on START subcommands, use ERJMP to catch CFORK
;failure, flush unopened JFN at ILISSA, check proper AC for terminator in AV2,
;check for no fork in CHKSYM (thanks MRC).
; Edit= 4436 to EXECP.MAC on 15-May-90 by GSCOTT
;Output PCs in halfword format if non-zero section.
; Edit= 4406 to EXECP.MAC on 22-Jun-88 by EVANS
;Allow DDT, GET, R, and RUN to get the right switch table by not using an AC
;which may have junk in it for a flag.
; UPD ID= 4125, RIP:<7.EXEC>EXECP.MAC.5, 7-Mar-88 18:24:52 by GSCOTT
;TCO 7.1255 - Update copyright notice.
; UPD ID= 4095, RIP:<7.EXEC>EXECP.MAC.4, 21-Jan-88 15:15:44 by EVANS
;More of TCO 7.1189 - EXEC Cleanup - Make the /OVERLAY switch invisible.
; UPD ID= 4094, RIP:<7.EXEC>EXECP.MAC.3, 19-Jan-88 16:03:10 by EVANS
;TCO 7.1189 - EXEC Cleanup. Convert input to SET PROG command to uppercase.
; Give more meaningful error message if user does FORK [name]
; for a nonexistent fork which has not had a SET PROG done
; for it.
; *** Edit 3063 to EXECP.MAC by MCCOLLUM on 21-Apr-87, for SPR #20642
; Release unwanted fork handles after a GFRKS% JSYS
; *** Edit 3061 to EXECP.MAC by EVANS on 2-Apr-87, for SPR #21169
; If PA1050 present, let it handle REENTER.
; Edit 3003 to EXECP.MAC by PRATT on 23-Jul-85, for SPR #20833
; START/BACK continuously re-starts programs in the background which try to
; read from the RSCAN buffer.
; UPD ID= 235, SNARK:<6.1.EXEC>EXECP.MAC.6, 10-Jun-85 08:44:34 by DMCDANIEL
; UPD ID= 159, SNARK:<6.1.EXEC>EXECP.MAC.5, 3-May-85 08:27:32 by DMCDANIEL
;Update copyrights for 6.1.
; UPD ID= 94, SNARK:<6.1.EXEC>EXECP.MAC.4, 15-Nov-84 15:13:54 by PRATT
;Clean up the edit history
; UPD ID= 92, SNARK:<6.1.EXEC>EXECP.MAC.3, 15-Nov-84 11:43:31 by PRATT
;TCO 6.1.1050 - Handle ephemoral programs correctly for batch
; UPD ID= 64, SNARK:<6.1.EXEC>EXECP.MAC.2, 12-Nov-84 03:47:52 by MERRILL
;TCO 6.1.1042 - Update PCL to the latest version we have
; Don't allow RESET, FORK, etc. to play with INVOKE'd forks.
; Make KEFORK check if it is killing the fork that was the
; current fork or the running fork before an INVOKE was done.
; Don't hang at WFORKX if the INVOKE'd program goes hungry before
; we hit the WFORK%.
; Look at FK%INV instead of PCPRGR to determine if fork is INVOKE'd.
; In FKTRM1 allow for the case where the INVOKE'd fork has started
; an inferior and the inferior has made the PTY/PDS go hungry.
; UPD ID= 436, SNARK:<6.EXEC>EXECP.MAC.62, 20-Aug-84 16:20:58 by PRATT
;TCO 6.2184 - Don't skip PIOFF after call to MAPPF in REPH
; UPD ID= 435, SNARK:<6.EXEC>EXECP.MAC.61, 20-Aug-84 15:57:38 by SANTIAGO
;More 6.2175 - Do GFRKS% in routine FRKNMX only if fork is unknown.
; UPD ID= 434, SNARK:<6.EXEC>EXECP.MAC.60, 15-Aug-84 16:59:28 by SANTIAGO
;TCO 6.2175 - Fix "FORK N" command to work when accessing unknown forks.
; UPD ID= 433, SNARK:<6.EXEC>EXECP.MAC.59, 3-Aug-84 17:12:19 by GLINDELL
;TCO 6.2161 - Use XSFRK% instead of SFORK% in DSFORK routine
; UPD ID= 432, SNARK:<6.EXEC>EXECP.MAC.58, 31-Jul-84 11:06:19 by PROBINSON
;More 6.2193 - Don't create page 0 if doesn't exist
; UPD ID= 431, SNARK:<6.EXEC>EXECP.MAC.57, 25-Jul-84 14:26:49 by MCCOLLUM
; More TCO 6.2091. Fix a bug in new code.
; UPD ID= 426, SNARK:<6.EXEC>EXECP.MAC.56, 19-Jul-84 17:45:18 by PROBINSON
;More TCO 6.2133 - Catch PDVOP% errors
; UPD ID= 423, SNARK:<6.EXEC>EXECP.MAC.55, 18-Jul-84 16:57:17 by PROBINSON
;TCO 6.2133 - XDDT changes
; UPD ID= 412, SNARK:<6.EXEC>EXECP.MAC.54, 13-Jun-84 16:45:41 by MCCOLLUM
;TCO 6.2097 - Fix code at .CSIGN to make START /SIGNAL work.
; UPD ID= 409, SNARK:<6.EXEC>EXECP.MAC.53, 7-Jun-84 17:22:11 by MCCOLLUM
;TCO 6.2091 - Be sure page exists in CHKSYM before mapping it
; UPD ID= 395, SNARK:<6.EXEC>EXECP.MAC.52, 20-Mar-84 15:25:30 by MCCOLLUM
;TCO 6.2004 - Fix 'NAME' command to remember attributes
; UPD ID= 357, SNARK:<6.EXEC>EXECP.MAC.51, 8-Dec-83 11:12:17 by PRATT
;More TCO 6.1881 - Make the old M-F commands invisible.
; UPD ID= 356, SNARK:<6.EXEC>EXECP.MAC.50, 1-Dec-83 14:04:46 by PRATT
;More TCO 6.1881 - Call .STRT2 from PROGK, not .STRT1.
; UPD ID= 346, SNARK:<6.EXEC>EXECP.MAC.49, 28-Nov-83 12:51:08 by PRATT
;More TCO 6.1881 - Remove a bad confirm.
; UPD ID= 345, SNARK:<6.EXEC>EXECP.MAC.48, 28-Nov-83 11:31:26 by PRATT
;TCO 6.1881 - Make STAY, BACKGROUND, and NORMALLY become switches.
; UPD ID= 307, SNARK:<6.EXEC>EXECP.MAC.47, 18-Aug-83 14:43:48 by PRATT
;TCO 6.1780 - Make the CSAVE command parse a little cleaner.
; UPD ID= 295, SNARK:<6.EXEC>EXECP.MAC.46, 5-Jul-83 17:04:56 by CHALL
;TCO 6.1652 - PUT "BACKGROUND" SUBCOMMAND BACK TOO (STAY NOW ACTS LIKE STAY)
; UPD ID= 283, SNARK:<6.EXEC>EXECP.MAC.45, 11-May-83 10:08:55 by CHALL
;TCO 6.1652 - PUT "STAY" SUBCOMMAND BACK AGAIN (BEHAVING LIKE "BACKGROUND")
; UPD ID= 280, SNARK:<6.EXEC>EXECP.MAC.44, 5-May-83 13:19:20 by CHALL
;TCO 6.1646 - TURN OFF M-F SUBCMDS TO CONT, START (UNDER XTND)
; UPD ID= 271, SNARK:<6.EXEC>EXECP.MAC.43, 20-Apr-83 11:09:46 by CHALL
;MORE TCO 6.1456 GET1- MAKE R, RUN, GET FORCE OVERLAY SWITCH
; UPD ID= 257, SNARK:<6.EXEC>EXECP.MAC.42, 1-Apr-83 14:02:07 by CHALL
;TCO 6.1456 GSWIS- ADD OVERLAY SWITCH; teach GSWIS callers to recognize
; /OVERLAY. Make default be not to overlay.
; UPD ID= 256, SNARK:<6.EXEC>EXECP.MAC.41, 8-Feb-83 10:26:07 by TSANG
;TCO 6.1490 - Don't allow multiple /USE-SECTION: switch.
; UPD ID= 245, SNARK:<6.EXEC>EXECP.MAC.40, 15-Jan-83 19:25:06 by CHALL
;TCO 6.1465 CHANGE NOISE OF SET NAME COMMAND TO (OF CURRENT FORK)
;TCO 6.1464 - UPDATE COPYRIGHT NOTICE
; UPD ID= 140, SNARK:<6.EXEC>EXECP.MAC.36, 4-Aug-82 17:26:24 by LEACHE
;TCO 6.1209 Fix JSYS trapping
; UPD ID= 129, SNARK:<6.EXEC>EXECP.MAC.34, 16-Jul-82 15:01:36 by WALLACE
;TCO 6.1186 - Make DDT command map and start DDT in same section as
; entry vector if no special section given and fork does exist
; UPD ID= 119, SNARK:<6.EXEC>EXECP.MAC.33, 20-Apr-82 07:54:38 by CHALL
;TCO 6.1097 DSFORK- Try SFORK before doing XSFRK
;TCO 6.1092 KEFRK2- INFTR2- Remove MIC conditionals
; UPD ID= 105, SNARK:<6.EXEC>EXECP.MAC.31, 29-Jan-82 14:14:37 by WALLACE
;TCO 5.1707 - Make START command always use XSFRK% (never SFORK%) when
; user gives an octal address
; UPD ID= 97, SNARK:<6.EXEC>EXECP.MAC.30, 8-Jan-82 15:56:39 by CHALL
;TCO 6.1052 - UPDATE COPYRIGHT NOTICE AND DELETE PRE-V4.1 EDIT HISTORY
; UPD ID= 78, SNARK:<6.EXEC>EXECP.MAC.28, 6-Nov-81 12:59:28 by CHALL
;TCO 5.1603 CHANGE THE NAME OF OP-CODE 415 FROM XHLLI TO XMOVEI
; UPD ID= 69, SNARK:<6.EXEC>EXECP.MAC.27, 10-Oct-81 20:19:39 by CHALL
;TCO 5.1564 ADD "PRESERVE (PCL ENVIRONMENT)"; DELETE SAVE/ENV AND SAVE/EXEC
; UPD ID= 64, SNARK:<6.EXEC>EXECP.MAC.26, 2-Oct-81 10:49:18 by CHALL
;TCO 5.1543 .CSAVE AND .SAVE- PUT BACK (on file) NOISES
; UPD ID= 57, SNARK:<6.EXEC>EXECP.MAC.25, 21-Sep-81 09:26:55 by CHALL
;TCO 5.1519 .FREEZ- DON'T ALLOW FORK 0 TO BE FROZEN
; UPD ID= 52, SNARK:<6.EXEC>EXECP.MAC.21, 10-Sep-81 14:18:49 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= 47, SNARK:<6.EXEC>EXECP.MAC.19, 31-Aug-81 11:57:22 by CHALL
;TCO 5.1480 $CONT1- USE LABEL $CONF1 WHEN NOT 1ST TIME THROUGH
; UPD ID= 37, SNARK:<6.EXEC>EXECP.MAC.16, 19-Aug-81 10:55:59 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= 29, SNARK:<6.EXEC>EXECP.MAC.15, 17-Aug-81 10:40:50 by CHALL
;TCO 5.1454 CHANGE NAME FROM XDEF TO EXECDE
; UPD ID= 15, SNARK:<6.EXEC>EXECP.MAC.13, 21-Jul-81 12:31:15 by MURPHY
;TCO 5.1427 - Get rid of PNTMES in $GET2.
; UPD ID= 5, SNARK:<6.EXEC>EXECP.MAC.12, 14-Jul-81 14:11:01 by MURPHY
;TCO 5.1410 - OVER QUOTA, MACH SIZE EXCEEDED, ETC.
; UPD ID= 2245, SNARK:<6.EXEC>EXECP.MAC.11, 23-Jun-81 15:12:55 by OSMAN
;more 6.1023 - allow ddt/use-section:n even if no program
; UPD ID= 2240, SNARK:<6.EXEC>EXECP.MAC.10, 23-Jun-81 09:53:20 by OSMAN
;more 5.1225 - Make address break announce correctly
; UPD ID= 2221, SNARK:<6.EXEC>EXECP.MAC.9, 19-Jun-81 09:08:44 by OSMAN
;More 6.1023 - If no switch on DDT command, use current DDT section
; UPD ID= 2214, SNARK:<6.EXEC>EXECP.MAC.8, 18-Jun-81 16:00:20 by OSMAN
;TCO 6.1023 - Make DDT/Use-section:n use n even if DDT already loaded elsewhere
; UPD ID= 2124, SNARK:<6.EXEC>EXECP.MAC.7, 4-Jun-81 09:53:56 by GRANT
;Add test for DSFF in ..STCR
; UPD ID= 2117, SNARK:<6.EXEC>EXECP.MAC.6, 3-Jun-81 09:48:10 by OSMAN
;tco 6.1016 - prevent undeserved "?Address is not between 0 and 37,,777777"
; UPD ID= 2044, SNARK:<6.EXEC>EXECP.MAC.5, 20-May-81 09:22:36 by OSMAN
;tco 6.1013 - Fix DDT command not to say "?Invalid section number"
; UPD ID= 2024, SNARK:<6.EXEC>EXECP.MAC.4, 19-May-81 10:22:16 by PURRETTA
;<6.EXEC>EXECP.MAC.4, 13-Apr-81 15:05:15, Edit by DK32
;PCL Add program-waiting flag to prevent hangs
; 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
; 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)
; COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1976, 1990.
; ALL RIGHTS RESERVED.
;
; THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
; ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
; INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
; COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
; OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
; TRANSFERRED.
;
; THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
; AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
; CORPORATION.
;
; DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
; SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
;TOPS20 'EXECUTIVE' COMMAND LANGUAGE
SEARCH EXECDE
TTITLE EXECP
;THIS FILE CONTAINS
;PROGRAM COMMANDS, LIKE RESET, CONTINUE, RUN, R ETC.
DEFINE CONSTG < ;;COMMON STORAGE FOR CONTINUE, START COMMANDS
TRVAR <STADR,UFORK,FTW,TMPJFN,SJBUFP>
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>
TMNE FK%INV,SLFTAB(A) ;[PCL] Current fork was INVOKE'd?
ERROR <No program> ;[PCL] Don't let him do it
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
TMNE FK%INV,SLFTAB(A) ;[PCL] Current fork was INVOKE'd?
JRST RESET2 ;[PCL] Yes, pretend no such fork
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!FK%INV ;[PCL] KEPT OR BACKGROUND or INVOKE'd 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
CAMN A,MICFRK ;MIC HERE
SETOM MICFRK
MOVE B,[-2] ;[PCL] Special uninitialized value
CAMN A,PCFORK ;[PCL] Saved copy of FORK from INVOKE?
MOVEM B,PCFORK ;[PCL] Yep, don't want to restore to FORK later
CAMN A,PCRNFK ;[PCL] Saved copy of RUNFK from INVOKE?
MOVEM B,PCRNFK ;[PCL] Yep, we don't want to restore this value
RET
;STEP TO NEXT FORK
NXTFRK: MOVEI A,NFRKS-1 ;LOOK THRU TABLE
NXTFR1: SKIPN FRKTAB(A) ;EXISTS?
JRST NXTFR2 ;NO - TRY NEXT
MOVE B,FRKTAB(A) ;[PCL] Get fork flags
TXNE B,FK%INV ;[PCL] INVOKE'd fork?
JRST NXTFR2 ;[PCL] Yes, ignore it
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)
MOVE Q1,SLFTAB(B) ;REMEMBER ADDRESS OF FORK STATE BLOCK
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>
GCVEC% ;[3061] PA1050 loaded?
ERJMP R ;[3061] Error of some kind (fork gone?)
JUMPG B,R ;[3061] If PA1050, don't need entry vector
MOVE A,FORK ;[3061] Get forkhandle back
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 .CONT ;PARSE COMMAND
CALL $CONTI ;SET FORK
JRST ..CONT ;RESUME PROCESS
;Here to parse the CONTINUE command
.CONT: 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
.CONT0: MOVEI B,$CON1 ;INCLUDES $CON1 AND $CON2
TLOE Z,F1 ;FIRST OR SECOND TIME THRU ?
MOVEI B,$CON2 ;SECOND TIME.
CALL FLDSKP ;PARSE LINE
CMERRX
LOAD D,CM%FNC,.CMFNP(C) ;GET FUNCTION CODE
CAIN D,.CMCFM ;CR?
JRST .CONT4 ;YES - CHECK MODES
CAIN D,.CMCMA ;GOT A COMMA ?
JRST .CONT1 ;YES
CAIN D,.CMSWI ;SWITCH SEEN?
JRST .CONT3 ;YES - CHECK SUBCOMMANDS
HRRZ A,C ;PICK UP FLDDB. WHICH SCORED
CAIN A,$$PMOD ;GOT $PMODE KEYWORD TABLE ?
JRST .CONT3 ;YES
CALL FRKNM0 ;PARSE NAME OR NUMBER
MOVEM A,UFORK ;SAVE HANDLE (DON'T TOUCH "FORK" CELL UNTIL CONFIRMATION!)
JRST .CONT0 ;TRY FOR SWITCHES OR CONFIRM
;Entries from above:
;
; .CONT1 called when a comma has been typed.
; .CONT2 called to make subcommands work on the same line as the comma.
; .CONT3 called when a switch or m-f keyword was typed.
; .CONT4 called when a confirm has been typed.
; .CONT5 is the common code for start and continue.
.CONT1: CRRX <Carriage return to enter subcommands>
JRST .CONT2
SUBCOM $CMODE ;MAKES SUBCOMMANDS WORK
JRST .CONT4
.CONT2: KEYWD $CMODE ;MAKES COMMA MF-KEYWORD WORK
0
CMERRX
CALL 0(P3) ;DO THE SUBCOMMAND
JRST .CONT4
.CONT3: HRRZ B,(B) ;B HAS ENTRIES ADDR, GET ADDR OF DISPATCH
CALL @(B) ;GO TO PROPER ROUTINE.
.CONT4: 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
.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
;Options for the "CONTINUE" command, ($CON1 includes $CON2)
$CON1:
$$PMOD: FLDDB. .CMKEY,CM%SDH,$PMODE,,,[
FLDDB. .CMKEY,,FRKNMS,<Fork name,>,,[
FLDDB. .CMNUM,CM%SDH,10,<Octal fork number>,,$CON2]]
;Option for the "START" command, ($STA1 includes $CON2)
$STA1: FLDDB. .CMNUM,CM%SDH,10,<Octal start address>,,$CON2
;Common multi-forking switches for both "START" and "CONTINUE"
$CON2: FLDDB. .CMSWI,,$CMODE,,,[
FLDDB. .CMCMA,CM%SDH,10,,,[
FLDDB. .CMCFM]]
;Subcommand table and routines
$CMODE: TABLE
T BACKGROUND
XTND,<
T INPUT,,.CINPU
T NO,,.CNO
>
T NORMALLY
XTND,<
T OUTPUT,,.COUTP
T QUIET,,.CQUIE
T SIGNAL,,.CSIGN
>
T STAY
TEND
;Keyword table for special case of CONT STAY, CONT NORMALLY
$PMODE: TABLE
T NORMALLY
T STAY
TEND
;Set BACKGROUND mode
.BACKG: CONFIRM
.CBAC2: MOVEI A,677777 ;SET FOR INPUT TRAP
.CSIGI: HRLM A,TMPJFN ;SET PRIMARY INPUT
SETOM STAYF ;STAY AT COMMAND LEVEL
RET ;EXIT
;STAY at command level
.STAY: CONFIRM
SETOM STAYF ;STAY AT COMMAND LEVEL
RET ;EXIT
;Set NORMAL mode
.NORMA: CONFIRM
SETZM STAYF ;I.E. NO STAY
RET
XTND,<
;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>
MOVX B,GJ%OLD!GJ%MSG ;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
;SIGNAL TTY I/O
.CSIGN: NOISE <WHEN TTY WANTED FOR>
SKIPA D,[677777] ;CAUSE PRIMARY TRAP
.CNO: MOVEI D,.NULIO ;NULL DEVICE
.CSIG2: KEYWD $CSIGN
T EITHER,,.CSIGB ;DEFAULT TO EITHER
JRST CERR
CONFIRM
MOVE A,D ;GET DEVICE CODE IN A
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
SETOM STAYF ;STAY AT COMMAND LEVEL
RET ;EXIT
> ;END XTND
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>
MOVE A,CMABP ;[7.1189] Point to what was typed
CALL UPRCAS ;[7.1189] Make it uppercase
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 .STRT2,[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
MOVEM A,UFORK ;[4444] Save fork here too
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,
;FIND START ADDRESS VIA PDV, START DDT
.DDT:: TRVAR <DDTSEC,DDTOVL,<DDTPDV,1+.POADE>,PDVA,UDDT,JBSYM,JBUSY,SA>
TXO Z,F7 ;[7.1189][4406] signal we were here
CALL GSWIS ;PARSE POSSIBLE SWITCHES
MOVEM C,DDTOVL ;SAVE THE OVERLAY FLAG
MOVEM B,DDTSEC ;SAVE POSSIBLE SPECIAL SECTION
SETZM UDDT ;NOT USING UDDT YET
SETZM JBSYM ;NO SYM POINTERS YET EITHER
MOVEI A,1+.POADE ;INITIALIZE PDV ARG BLOCK
MOVEM A,.POCT1+DDTPDV ;BLOCK LENGTH
MOVEI A,1 ;ONLY ONE WORD IN DATA BLOCK
MOVEM A,.POCT2+DDTPDV
XMOVEI A,PDVA ;ADDRESS OF THE DATA BLOCK
MOVEM A,.PODAT+DDTPDV
SETZM .POADR+DDTPDV ;RANGE IS ALL OF MEMORY
HRLOI A,37
MOVEM A,.POADE+DDTPDV
;FIRST LOOK FOR DDT'S PDV. IF IT'S THERE, WE WANT TO START IT WITHOUT
;HAULING IN ANOTHER COPY.
SKIPG A,FORK ;GOT A FORK?
JRST DDT0 ;NO - CAN'T BE ANY PDVS, NOT COMPATIBLE
MOVEM A,.POPHD+DDTPDV ;REMEMBER WHICH FORK
MOVEI A,.POLOC ;LOOK FOR PDVS BY NAME
XMOVEI B,DDTPDV ;ARG BLOCK
HRROI C,[ASCIZ/DDT%/] ;DDT'S PDV NAME
PDVOP%
ERJMP DDT5 ;SOMEBODY DIED, ASSUME DDT'S NOT THERE
SKIPN .POCT2+DDTPDV ;IS DDT ALREADY THERE?
JRST DDT5 ;NO, NEED TO BRING ONE IN
SKIPGE DDTSEC ;WAS A SECTION SPECIFIED?
JRST XDDTIN ;NO, GO START DDT
HLRZ A,PDVA ;YES, GET DDT'S SECTION
CAME A,DDTSEC ;IS IT THE SAME?
ETYPE <%%DDT already loaded in section %1P%%_> ;NO, TSK TO USER
JRST XDDTIN ;GO START EXTANT DDT
;DDT IS NOT ALREADY IN THE FORK. CHECK TO SEE IF WE SHOULD BRING IN
;THE UDDT STUB INSTEAD OF THE REAL THING.
DDT5: SKIPLE DDTSEC ;USER SPECIFY A NON-ZERO SECTION?
JRST DDT0 ;YES, HE KNOWS BETTER THAN WE
MOVE A,FORK ;GET THE FORK
GCVEC ;IS PA1050 AROUND?
JUMPG B,DDT6 ;YES, WANT UDDT IN ZERO
MOVE A,FORK ;GET FORK AGAIN
CALL GETENT ;FIND THE ENTRY VECTOR
TLNN C,-1 ;IN SECTION ZERO?
CAIE B,(JRST) ;TOPS-10 STYLE?
JRST DDT0 ;NO, USE REAL DDT
;DDT...
;THE FORK HAS A TOPS-10 STYLE ENTRY VECTOR IN SECTION ZERO.
;CHECK .JBDDT BEFORE BRINGING IN UDDT.
DDT6: MOVEI A,JOBDDT ;LOCATION FOR DEBUGGER ADDRESS
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 DDTOLD ;NO USABLE PTR
HRRZ A,PAGEN(A) ;SEE IF ALREADY HAVE START ADDRESS
JUMPG A,[MOVEM A,SA ;YES, SAVE IT
SETOM UDDT ;WANT TO FOLLOW SAME PATH
JRST DDTIN] ; AND JOIN COMMON CODE
;WE WILL BE BRINGING IN UDDT. GRAB THE SYMBOL TABLE POINTERS, SINCE
;WE HAVE THE PAGE MAPPED ALREADY.
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
MOVEM C,JBSYM ;REMEMBER SYMBOL TABLE POINTER
MOVEM D,JBUSY ;REMEMBER UNDEFINED SYMBOL TABLE POINTER
JRST DDTOLD ;USE THE STUB
;WE WANT TO LOAD IN THE REAL DDT. IF A SECTION WAS ASKED FOR, IT
;CAN'T ALREADY EXIST UNLESS /OVERLAY WAS SPECIFIED. IF NO SECTION
;WAS GIVEN, USE THE HIGHEST NON-EXISTANT SECTION.
DDT0: SKIPL A,DDTSEC ;WAS A SECTION SPECIFIED?
JRST DDT3 ;YES, CHECK FOR EXISTANCE
MOVEI C,37 ;NO, START WITH HIGHEST SECTION
SKIPG FORK ;FORK EXIST?
JRST DDT2 ;NO, JUST USE 37
DDT1: HRL A,FORK ;IN THIS FORK
HRR A,C ;GET SECTION NUMBER
RSMAP% ;GET MAPPING INFO
CAME A,[-1] ;SECTION EXIST?
SOJG C,DDT1 ;YES, TRY THE NEXT ONE
JUMPN C,DDT2 ;FIND A SECTION?
SKIPN DDTOVL ;/OVERLAY GIVEN?
ERROR <No free section for DDT> ;NO, MAKE USER TYPE IT
MOVEI C,37 ;YES, DEFAULT BACK TO 37 (NO FREE SECTION)
DDT2: MOVEM C,DDTSEC ;STORE SECTION NUMBER
JRST DDTGET ;AND GO HAUL IT IN
DDT3: SKIPLE FORK ;FORK EXIST?
SKIPE DDTOVL ;ALLOWED TO OVERLAY?
JRST DDTGET ;NO FORK OR /OVERLAY, IT'S OK
HRL A,FORK ;GET THE FORK HANDLE
RSMAP% ;SEE IF THE SECTION IS THERE
CAMN A,[-1] ;IS IT?
JRST DDTGET ;NO, WE CAN USE IT
ERROR <Section already exists> ;YES, COMPLAIN
;DDT...
;LOAD IN DDT
DDTOLD: SETZM DDTSEC ;STUB COMES INTO SECTION ZERO
SETOM UDDT ;FLAG USING UDDT
SKIPA B,[POINT 7,[GETSAVE(SYS:UDDT.)]]
DDTGET: MOVE B,[POINT 7,[GETSAVE(SYS:XDDT.)]]
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 SECTION TO MERGE ROUTINE
MOVE C,DDTOVL ;DITTO OVERLAY FLAG
CALL $MERGE ;MERGE IT INTO FORK, CREATING FORK IF NONE,
;AND RELEASE JFN
SKIPN UDDT ;DID WE JUST BRING IN UDDT?
JRST DDT8 ;NO, GO CHECK FOR PDVS
;STORE SYMBOL TABLE POINTERS
SKIPL JBSYM ;SYMBOL POINTER?
JRST DDT4 ;NO
MOVEI A,DDTSYM ;WHERE DDT'S STUFF ADDRESSES ARE
HRL A,DDTSEC
CALL MAPPF
JRST CJERRE ;FAILED -- TYPE JSYS ERROR
ANDI A,777
HRR Q1,PAGEN+1(A) ;WHERE TO STORE UNDEF POINTER
HRR A,PAGEN(A) ;POINTER TO WHERE TO PUT POINTER
HRL A,DDTSEC ;SAY WHICH SECTION TO LOOK IN
CALL MAPPF
CALL CJERRE ;FAILED -- TYPE JSYS ERROR
ANDI A,777
MOVE C,JBSYM ;GET THE SYMBOL POINTER
MOVEM C,PAGEN(A) ;STORE POINTER INTO DDT'S GUTS
HRR A,Q1 ;WHERE TO PUT UNDEF PTR IN DDT
HRL A,DDTSEC ;LOOK IN CORRECT SECTION
CALL MAPPF
CALL CJERRE ;FAILED -- TYPE JSYS ERROR
ANDI A,777
MOVE D,JBUSY ;GET UNDEFINED POINTER
MOVEM D,PAGEN(A) ;STORE IT
DDT4: MOVEI B,DDTORG ;GET START ADDRESS OF DDT
HRL B,DDTSEC ;GIVE IT CORRECT SECTION
MOVEM B,SA ;REMEMBER DDT'S START ADDRESS
JRST DDTIN ;GO START DDT
;DDT...
;HERE TO FIND XDDT'S START ADDRESS. FIRST STEP IS TO FIND THE PDV.
DDT8: MOVE A,FORK ;GET THE FORK
MOVEM A,.POPHD+DDTPDV ;REMEMBER IT
MOVEI A,1 ;RESET DATA BLOCK COUNT
MOVEM A,.POCT2+DDTPDV ;TO SOMETHING SENSIBLE
MOVEI A,.POLOC ;FIND PDV BY NAME
XMOVEI B,DDTPDV ;WITH THIS ARG BLOCK
HRROI C,[ASCIZ/DDT%/] ;DDT'S PDV NAME
PDVOP%
ERJMP [ERROR <PDVOP%% error loading DDT - %?>] ;CAN'T FIND IT!?
SKIPN .POCT2+DDTPDV ;FIND ONE?
ERROR <Error loading DDT - cannot find PDV> ;NO???
;HERE WITH XDDT MAPPED IN. THE START ADDRESS IS LOCATED VIA THE
;PDV (SECOND WORD IN THE EXPORT VECTOR).
IFNDEF .PVEXP,<.PVEXP==.PVSTR> ;TEMP TILL MONSYM FIXED
XDDTIN: MOVE A,PDVA ;GET THE PDV ADDRESS
ADDI A,.PVEXP ;EXPORT VECTOR WORD
CALL MAPPF ;MAP IN THE PAGE
JRST CJERRE ;COULDN'T
ANDI A,777 ;REDUCE TO PAGE OFFSET
MOVE A,PAGEN(A) ;GET EXPORT VECTOR ADDRESS
TXNE A,IFIW ;IS IT LOCAL?
HLL A,PDVA ;YES, SET THE SECTION
ADDI A,1 ;POINT TO SECOND WORD OF EXPORT BLOCK
HLLM A,SA ;HANG ONTO VECTOR SECTION FOR A MOMENT
CALL MAPPF ;MAP IN THE PAGE
JRST CJERRE ;COULDN'T
TXNE B,PA%PEX ;EXPORT VECTOR EXIST?
TXNN B,PA%RD ;IS IT READABLE?
ERROR <Unable to start DDT> ;NOPE
ANDI A,777 ;REDUCE TO PAGE OFFSET
MOVE A,PAGEN(A) ;GET EXPORT VECTOR ADDRESS
TXNE A,IFIW ;IS IT LOCAL?
HLL A,SA ;YES, RESET SECTION
MOVEM A,SA ;SAVE THE START ADDRESS
;HERE WITH DDT'S START ADDRESS IN SA. FIGURE OUT IF WE NEED TO
;START IT VIA PA1050.
DDTIN: SETZM STAYF ;? FORK CAN'T BE BACKGROUND??
MOVNI B,3 ;SEE IF PA1050 PRESENT
CALL NOPAT ;IF SO, FIX UP ITS ENTRY VECTOR
JRST GOTO2 ; AND RESTART VIA PA1050
MOVE B,SA ;NO PA1050, DEBUGGER STARTS HERE
JRST GOTO2 ;GO START IT
;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 <No such fork> ;[7.1189] Make error message more meaningful
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> ;[4444]
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 <OF CURRENT FORK>
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
MOVEI A,FRKNMS ;FORK NAME TABLE
HRRO B,.FKNAM(Q1) ;POINT TO CURRENT NAME
TBLUK ;LOOK UP NAME IN TABLE
TXNN B,TL%EXM ;MATCH?
JRST NEWNAM ;NOT IN TABLE, STRANGE
HRRZ Q1,(A) ;GET ADDRESS OF FORK BLOCK
LOAD C,FKFLAG,(Q1) ;GET FLAGS
TXNE C,FN%NAT!FN%ATT ;ARE THERE ATTRIBUTES TO THIS NAME?
CALLRET SETNAM ;YES. GO DO THE WORK
;
;EITHER THE FORK NAME ISN'T IN THE TABLE, WHICH SHOULDN'T HAPPEN, OR THE
;FORK DOESN'T HAVE ANY ATTRIBUTES WORTH PRESERVING.
;
NEWNAM: MOVE A,FORK ;GET FORK
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
;CHANGE THE NAME OF A FORK THAT HAS ATTRIBUTES SET. SAVE THE ATTRIBUTES OF
;THE OLD FORK AND THEN CALL DELNAM TO LOSE THE NAME. THEN CALL ADDNAM TO
;PUT THE NEW NAME IN THE TABLE. IF THE NEW NAME MATCHES A FORK NAME THAT
;HAS ATTRIBUTES BUT DOES NOT EXIST, USE THE ATTRIBUTES OF THE NEW NAME AND
;TELL THE USER WHAT THE NEW ATTRIBUTES ARE. IF NOT, RESTORE THE ATTRIBUTES
;OF THE OLD NAME TO THE NEW NAME.
SETNAM: STKVAR <OLDATB>
MOVE A,Q1 ;GET ADDRESS OF FORK BLOCK IN A
CALL SAVATT ;SAVE ATTRIBUTES OF OLD NAME
MOVEM A,OLDATB ;SAVE ADDRESS OF OLD ATTRIBUTE BLOCK
MOVE A,FORK ;GET FORK
MOVE Q1,SLFTAB(A) ;POINT TO FORK DATA BLOCK
CALL DELNAM ;DELETE OLD NAME
MOVEI A,FRKNMS ;POINT TO TABLE
HRROI B,ATMBUF ;POINT TO NAME
TBLUK ;CHECK EXISTS ALREADY
TXNN B,TL%EXM ;EXACT MATCH?
JRST NOATT ;NO. THEN IT CAN'T HAVE ATTRIBUTES
HRRZ B,(A) ;GET ADDRESS OF FORK BLOCK
LOAD C,FKFLAG,(B) ;GET FLAGS
LOAD D,FKHAN,(B) ;GET FORK HANDLE
SKIPG D ;IS THE FORK NOT ACTIVE?
TXNN C,FN%NAT ;AND ARE THERE ATTRIBUTES TO THIS NAME?
SKIPA ;FORK ACTIVE OR NO ATTRIBUTES
JRST NEWATT ;NOT ACTIVE AND ATTRIBUTES. GO HANDLE
NOATT: MOVE A,FORK ;GET FORK HANDLE IN A
HRROI B,ATMBUF ;POINT TO NEW NAME
CALL ADDNAM ;ADD IT TO TABLE(S)
MOVE A,OLDATB ;GET ADDRESS OF OLD ATTRIBUTE BLOCK
MOVE B,FORK ;GET CURRENT FORK NUMBER
CALL RSTATT ;RESTORE THEM
RET ;DONE
;HERE IF THE FORK NAME IS ALREADY KEPT (BY 'SET PROGRAM') AND IS NOT YET
;ACTIVE.
NEWATT: MOVE A,OLDATB ;GET ADDRESS OF OLD ATTRIBUTE BLOCK
CALL RETATT ;RETURN ATTRIBUTE BLOCK
MOVE A,FORK ;GET FORK HANDLE IN A
HRROI B,ATMBUF ;POINT TO NEW NAME
CALL ADDNAM ;ADD IT TO TABLE(S)
MOVE A,FORK ;GET FORK HANDLE
MOVE A,SLFTAB(A) ;GET ADDRESS OF FORK TABLE
HRRZ A,.FKNAM(A) ;GET ADDRESS OF FORK NAME
HRLI A,440700 ;MAKE BYTE POINTER
ETYPE <[Assuming attributes of %1M]>
RET ;DONE
;SAVATT
;
;SAVE THE ATTRIBUTES OF A FORK IN A FORK BLOCK.
;CALL:
; A/ ADDRESS OF FORK BLOCK
;RETURNS:
; +1: ALWAYS, ADDRESS OF BLOCK IN A
;
SAVATT: STKVAR <FBLOCK>
MOVEM A,FBLOCK ;SAVE ADDRESS OF BLOCK
CALL PIOFF ;TURN OFF ^C WHILE PLAYING IN FREE SPACE
CALL GETFBK ;GET A NEW FORK BLOCK
HRL B,FBLOCK ;GET ADDRESS OF OLD BLOCK
HRR B,A ;ADDRESS OF NEW BLOCK
BLT B,FKTLEN-1(A) ;SAVE THE OLD BLOCK
CALL PION ;DONE. TURN ^C BACK ON
RET ;AND RETURN
;RSTATT
;
;RESTORES THE ATTRIBUTES OF A FORK BLOCK FROM A GIVEN BLOCK
;CALL:
; A/ ADDRESS OF BLOCK TO RESTORE FROM
; B/ FORK
;RETURNS:
; +1: ALWAYS
;
RSTATT: STKVAR <OBLOCK>
MOVEM A,OBLOCK ;SAVE OLD BLOCK ADDRESS
MOVE Q1,SLFTAB(B) ;POINT TO FORK DATA BLOCK
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 REMBLK ;BAD. FORK WILL HAVE NO NAME
HRRZ A,(A) ;GET ADDRESS OF FORK BLOCK
LOAD C,FKHAN,(A) ;REMEMBER FORK HANDLE
HRL B,OBLOCK ;GET ADDRESS OF OLD BLOCK
HRR B,A ;AND ADDRESS OF NEW BLOCK
BLT B,FKTLEN-1(A) ;RESTORE THE ATTRIBUTES
STOR C,FKHAN,(A) ;RESTORE FORK HANDLE
LOAD B,FKFLAG,(A) ;GET FORK FLAGS
TXZ B,FN%NAT ;TURN OFF PERMANENT ATTRIBUTE FLAG
TXO B,FN%ATT ;TURN ON TEMPORARY ATTRIBUTE FLAG
STOR B,FKFLAG,(A) ;RESTORE FLAG WORD
REMBLK: MOVE A,OBLOCK ;GET ADDRESS OF OLD BLOCK
;ENTRY POINT TO RELEASE BLOCK WITHOUT RESTORING ATTRIBUTES. TAKES ADDRESS
;OF BLOCK IN A
RETATT: MOVEI B,FKTLEN ;GET LENGTH OF BLOCK
CALL RETBUF ;RELEASE IT
RET ;DONE
;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,MEROVL>
MOVEM A,MERJFN ;SAVE PROGRAM BEING MERGED
MOVEM B,MERSEC ;AND SECTION NUMBER
MOVEM C,MEROVL ;AND OVERLAY FLAG
SKIPGE D,FORK ;SKIP IF EXEC HAS INFERIOR FORK
JRST $GET2 ;NO FORK, CREATE ONE, GET PROG, USE ITS ENTRY.
MOVE A,D ;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
MOVE C,MEROVL
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
; C/ 0==don't overlay, -1==overlay
$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 (INTO B AND C)
MOVE A,SGJFN ;RETURN JFN IN A
RET
;GSWIS gets switches for GET-class commands.
;
;Returns: B/ -1 or special section
; C/ 0==don't overlay, -1==overlay
GSWIS: TRVAR <USESEC,OVERLY>
SETZM OVERLY ;SAY DON'T OVERLAY
SETOM USESEC ;SAY NO SPECIAL SECTION TO USE
GSWIS1: MOVEI B,[FLDDB. .CMSWI,,GETSWI,,,[
FLDDB. .CMCFM]]
TXNE Z,F7 ;[7.1189][4406] need DDT table
MOVEI B,[FLDDB. .CMSWI,,DDTSWI,,,[
FLDDB. .CMCFM]] ;[7.1189] yes
SKIPGE USESEC ;[7.1189] HAS THE USE-SECTION SWITCH BEEN USED?
IFSKP.
MOVEI B,[FLDDB. .CMSWI,CM%SDH,GETSW2,,,[
FLDDB. .CMCFM]] ;YES - DON'T ALLOW IT AGAIN
TXNE Z,F7 ;[7.1189][4406] DDT seen?
MOVEI B,[FLDDB. .CMSWI,,DDTSW2,,,[
FLDDB. .CMCFM]] ;[7.1189] yes
ENDIF.
CALL FLDSKP ;SEE WHAT'S BEING TYPED
CMERRX
LOAD D,CM%FNC,.CMFNP(C)
CAIE D,.CMSWI ;SWITCH?
JRST GSWIS2 ;NO - RETURN WITH THE RIGHT VALUES
CALL GETKEY ;YES - SEE WHICH ONE
CALL (P3) ;EXECUTE THE SWITCH
JRST GSWIS1 ;GET MORE INPUT
GSWIS2: MOVE B,USESEC ;RETURN -1 OR SECTION IN B
MOVE C,OVERLY ;RETURN OVERLAY/DON'T OVERLAY FLAG
RET
;Table of switches for GET-class commands
;[7.1189]
DDTSWI: TABLE ;[7.1189]
T OVERLAY,,GOVER ;[7.1189]
T USE-SECTION:,,GUSE ;[7.1189]
TEND ;[7.1189]
GETSWI: TABLE
IT OVERLAY,,GOVER ;[7.1189]
T USE-SECTION:,,GUSE
TEND
;[7.1189]
DDTSW2: TABLE ;[7.1189] SWITCHES WHEN /USE-SEC ALREADY USED
T OVERLAY,,GOVER ;[7.1189]
TEND ;[7.1189]
GETSW2: TABLE ;SWITCHES WHEN /USE-SEC ALREADY USED
IT OVERLAY,,GOVER
TEND
GOVER: SETOM OVERLY ;SAY NEW STUFF CAN OVERLAY THE EXISTING STUFF
RET ;DONE
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.
SETO C, ;FORCE OVERLAY FLAG
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
; C/ 0==don't overlay, -1==overlay
$GET0:: SETO B, ;SPECIAL ENTRY TO FORCE NO SPECIAL SECTION
$GET2:: STKVAR <GETJFN,GETSEC,GETOVL,<GBLK,1+.GBASE>>
;IF THERE IS NO INFERIOR FORK, CREATE ONE.
MOVEM A,GETJFN ;SAVE WHICH FILE TO GET
MOVEM B,GETSEC ;AND WHICH SECTION TO USE
MOVEM C,GETOVL ;AND THE OVERLAY FLAG
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
SKIPN GETOVL ;WANT TO PREVENT OVERLAYING EXISTING STUFF?
TXO A,GT%NOV ;YES - SET THAT FLAG
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
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)
IFJER. ;[4444] If creation fails
PUSH P,A ;[4444] Save error code
MOVEI A,.FKSZE ;[4444] Load size
MOVE B,Q1 ;[4444] and block addrs
CALL RETBUF ;[4444] (A,B/) Return block
POP P,A ;[4444] Restore error code from CFORK
JRST JERR ;[4444] Tell user about it
ENDIF. ;[4444] End of CFORK failed code
MOVEM A,FORK ;SAVE AS CURRENT FORK
HRRZM Q1,SLFTAB(A) ;SAVE POINTER TO FORK DATA
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
DSFRK0: LSHC B,-^D36 ;GET PC INTO AC B AND CLEAR FLAGS IN AC C
XSFRK% ;START THE FORK EXTENDEDLY
ERJMP DSFRK1 ;FAILED
RET ;O.K.
DSFRK1: CALL DGETER ;SEE WHY THE START FAILED
CAIE A,ILINS2 ;OLD MONITOR?
CALL JERR ;NO, STRANGE ERROR
ERROR <Start addresses larger than 18 bits illegal>
;"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
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
SKIPGE FORK
ERROR <No program>
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
CALL OPNERR ;[4444] (A,C/) Analyze and print error
MOVE A,SAVJFN ;[4444] Reload the JFN
TXO A,CZ%ABT ;[4444] Light the abort bit
CLOSF% ;[4444] Slam shut this JFN we don't want
ERJMP .+1 ;[4444] Ignore errors
RET ;[4444] and return
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 COMMAND DISPATCHES HERE
.START::NOISE <PROGRAM>
CONSTG ;ALLOCATE STORAGE
SETZM STAYF
MOVE A,FORK ;SET UP START FORK
MOVEM A,UFORK ;USE UFORK UNTIL CR SEEN FOR CONFIRMATION
.STA1: MOVEI B,$STA1 ;INCLUDES $STA1 AND $CON2
TLOE Z,F1 ;FIRST OR SECOND TIME THRU ?
MOVEI B,$CON2 ;SECOND TIME.
MOVEI B,$STA1 ;START COMND FUNCTIONS
CALL FLDSKP ;PARSE LINE
CMERRX
LOAD D,CM%FNC,.CMFNP(C) ;GET FUNCTION CODE
CAIN D,.CMCFM ;CR?
JRST .STRT2 ;YES
CAIN D,.CMCMA ;GOT A COMMA ?
JRST .STRT3 ;YES
CAIN D,.CMSWI ;SWITCH SEEN?
JRST .STRT1 ;YES - CHECK SUBCOMMANDS
MOVEM B,STADR ;SAVE START ADDRESS
TLO Z,F2 ;FLAG THE FACT THAT WE HAVE AN ADDRESS
JRST .STA1
;Entries from above:
;
; .STRT1 called when a switch has been typed
; .STRT2 called when a confirm has been typed.
; .STRT3 called when a comma has been typed.
; .STRT4 called to make subcommands work on the same line as the comma.
.STRT1: CALL .CONT3 ;LET THE CONTINUE CODE DISPATCH
.STRT2: TLNN Z,F2 ;USER GIVE A START ADR ?
IFSKP.
MOVE A,STADR ;YES
JRST .GOTO ;DO START THERE.
ENDIF.
CALL $START ;GET ADDRS
JRST STR1
.STRT3: CRRX <Carriage return to enter subcommands>
JRST .STRT4
SUBCOM $CMODE ;MAKES SUBCOMMANDS WORK
CALL .CONT4 ;DO THE WORK
JRST .STRT2
.STRT4: KEYWD $CMODE ;MAKES COMMA MF-KEYWORD WORK
0
CMERRX
CALL 0(P3) ;DO THE SUBCOMMAND
CALL .CONT4 ;DO THE WORK
JRST .STRT2
;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
;"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
SKIPN STAYF ;[3003] BACKGROUND STATUS ?
IFSKP. ;[3003]
HRROI A,[ASCIZ//] ;[3003] YES - MAKE NULL RSCAN BUFFER STRING
RSCAN ;[3003]
ERJMP .+1 ;[3003] IGNORE THE ERROR
JRST WAITF ;[3003] BYPASS
ENDIF. ;[3003]
;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
SETZM PCWAIT ;PCL Fork has not gotten hungry yet
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
SKIPN PCWAIT ;PCL Do not wait if we have just received PSI
WFORKX::WFORK ;PCL WAIT. WFORKX: M-U-S-T BE ON WFORK
FFORK ;FREEZE IT IMMEDIATELY
NOWAIT: SETZM PCWAIT
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
TMNN FK%INV,SLFTAB(A) ;[PCL] If not 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?
TMNE FK%INV,SLFTAB(A) ;[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
JRST WAITA] ;NOT EXPIRED, KEEP RUNNING FORK
CAIN C,.RFTRP ;JSYS/UUO TRAP???
JRST [ MOVE B,LRFSTS+.RFPPC ;LOAD PC FOR USE WITH %Y
ERROR <JSYS or UUO trap at %2Y>]
TMNE FK%INV,SLFTAB(A) ;[PCL] Controlled program?
JRST [ CAIE C,.RFIO ;[PCL] Yes - In I/O wait (Normal)
CAIN C,.RFWAT ;[PCL] Waiting for inferior?
RET ;[PCL] Probably inferior doing I/O to PTY/PDS
CAIE C,.RFRUN ;[PCL] Runnable,
CAIN C,.RFSLP ;[PCL] Or dismissed?
RET ;[PCL] Probably inferior doing I/O to PTY/PDS
JRST .+1] ;[PCL] else;invoked fork must have died somehow
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 D,YFLD,JINSTR ;GET JSYS NUMBER
LDB C,[POINT 9,JTAB(D),35] ;GET SECONDARY TABLE OFFSET
JUMPE C,JNDF ;JUMP IF JSYS NOT DEFINED
HLRO C,JTAB(C) ;GET POINTER TO JSYS RECORD
AOS C ;INCREMENT TO JSYS NAME
ETYPE <%@[%1M trap %2Y/ %3M Ac's 1-4: > ;TYPE NAME
JRST ACLP
JNDF: ETYPE <%@[%1M trap %2Y/ JSYS %4a Ac's 1-4: > ;TYPE NUMBER
ACLP: 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
TYPE <\ >
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)
MOVEI A,BUF0 ;[3063]Get address of GFRKS% block
CALL RELHAN ;[3063](A/)RELEASE SOME FORK HANDLES
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"]
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)
JFCL ;IGNORE THE ERROR
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
CALL SETPRG ;RUNNING A PROGRAM NOW
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 D,"." ;[4444] 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
TXNE A,SCFLD ;DON'T MATCH ON PROGRAM NAMES
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 <%1#> ;[4436] Output as "n" or "n,,m"
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?
SKIPA A,[FLD(1,OPFLD)!FLD(1,ACFLD)] ;YES, DENOTE THAT THESE FIELDS WERE PRINTED
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
SKIPGE FORK ;[4444] Is there a current fork?
ERROR <No program> ;[4444] Nope, report error to the user
STKVAR <INSYMP>
SETZM LASTP ;NO CACHED PROGRAM NAME YET
MOVEI A,JOBSYM ;SYMBOL TABLE POINTER ADDRESS
LSH A,-11 ;GET ONLY PAGE NUMBER
HRL A,FORK ;CURRENT FORK HANDLE
RPACS% ;READ PAGE ATTRIBUTES
MOVEI A,JOBSYM ;POINT TO SYMBOL TABLE POINTER
TXNE B,PA%PEX ;DOES PAGE EXIST?
CALL RANDOM ;YES. READ SYMBOL TABLE POINTER
SETZ A, ;ASSUME 0
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, AT SIGN,
;LEFT PARENTHESIS, SKIPPING IF THE TOKEN IS SEEN.
RCMA: MOVEI B,[FLDDB. .CMTOK,CM%SDH,<-1,,[ASCIZ /,/]>,<Comma>]
CALLRET XSKP ;PARSE THE TOKEN; GIVE SKIP OR ERROR RETURN
RIND: MOVEI B,[FLDDB. .CMTOK,CM%SDH,<-1,,[ASCIZ /@/]>,<At sign (@)>]
CALLRET XSKP ;PARSE THE TOKEN; GIVE SKIP OR ERROR RETURN
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)
CALLRET XSKP ;PARSE THE TOKEN; GIVE SKIP OR ERROR RETURN
RSPACE: MOVEI B,[FLDDB. .CMTOK,CM%SDH,<-1,,[ASCIZ / /]>,<Space>]
CALLRET XSKP ;PARSE THE TOKEN; GIVE SKIP OR ERROR RETURN
;"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 AT SIGN
CAIA ;IT DOESN'T - TRY A COMMA
JRST HI ;IT DOES - HANDLE INDIRECT
CALL RCMA ;GOT A COMMA?
JRST NOOPC1 ;NO - TRY PARENTHESIS
CALL RCMA ;YES - SEE IF EXPRESSION STARTS WITH TWO COMMAS
JRST SCOMA ;",FOO" EQUALS ",,FOO"
JRST SCOMA
NOOPC1: CALL LPAREN ;TRY A PARENTHESIS
CMERRX <No opcode seen, and no comma (,) at sign (@) or parenthesis seen either>
SETZM YFLD ;NO Y FIELD
JRST HP ;HANDLE PARENTHESES
;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@"
CAIA ;NO - SKIP
JRST HI ;YES - HANDLE INDIRECT
CALL RCMA ;HOW ABOUT "FOO,"
JRST OPNAC1 ;NO - TRY OTHER THINGS
CALL RCMA ;IT'S "FOO,". HOW ABOUT "FOO,,"
JRST OPNAC2 ;NO - IT'S JUST "FOO,"
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
OPNAC1: 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 ("
OPNAC2: 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
;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
JUMPN A,RSKP ;IF SOMETHING READ GIVE A SKIP RETURN
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
CAIN C,")" ;CLOSING PARANTHESIS?
RET ;O.K.
CALLRET PARBAD ;NO, INVALID EXPRESSION
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 PPART2 ;YES, GET POSSIBLE SPECIAL LITERAL
PPART1: 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
PPART2: MOVE B,(A) ;GET POSSIBLE SPECIAL LITERAL
CAME B,[ASCII /[\]/] ;IS IT THE SPECIAL ONE?
JRST PPART1 ;NO - BACK TO THE FLOW
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
END