Trailing-Edge
-
PDP-10 Archives
-
SRI_NIC_PERM_SRC_3_19910112
-
mit/exec/execp.mac
There are 47 other files named execp.mac in the archive. Click here to see a list.
;[MIT-XX]SRC:<EXEC.TEST>EXECP.MAC.10, 24-Aug-84 05:12:39, Edit by GZ
;115 Add a NOP after a call to MAPPF (it skips).
;715 add CMU PCL 5(100) features
;713 add literals label
;712 DEC release version
; UPD ID= 135, SNARK:<5.EXEC>EXECP.MAC.16, 29-Jan-82 14:11:51 by WALLACE
;TCO 5.1707 - Make START command always use XSFRK% (never SFORK%) when
; user gives an octal address
; UPD ID= 123, SNARK:<5.EXEC>EXECP.MAC.11, 28-Dec-81 11:15:38 by CHALL
;TCO 5.1644 - UPDATE COPYRIGHT NOTICE
; UPD ID= 105, SNARK:<5.EXEC>EXECP.MAC.9, 6-Nov-81 13:29:24 by CHALL
;TCO 5.1603 CHANGE THE NAME OF OP-CODE 415 FROM XHLLI TO XMOVEI
; UPD ID= 85, SNARK:<5.EXEC>EXECP.MAC.8, 10-Oct-81 19:46:01 by CHALL
;TCO 5.1564 ADD "PRESERVE (PCL ENVIRONMENT)"; DELETE SAVE/ENV AND SAVE/EXEC
; UPD ID= 80, SNARK:<5.EXEC>EXECP.MAC.7, 2-Oct-81 10:35:53 by CHALL
;TCO 5.1543 .CSAVE AND .SAVE- PUT BACK (on file) NOISES
; UPD ID= 73, SNARK:<5.EXEC>EXECP.MAC.6, 21-Sep-81 09:09:15 by CHALL
;TCO 5.1519 .FREEZ- DON'T ALLOW FORK 0 TO BE FROZEN
; UPD ID= 70, SNARK:<5.EXEC>EXECP.MAC.3, 14-Sep-81 11:08:07 by CHALL
;TCO 5.1504 ..CONT- JRST WAITR INSTEAD OF WAITF, TO DO RESCAN (THIS IS 6.1003)
; UPD ID= 68, SNARK:<5.EXEC>EXECP.MAC.2, 10-Sep-81 14:12:03 by CHALL
;TCO 5.1500 $GET0- $GET2- SET UP FORK'S SECTION (IN CODSEC) AFTER GET
; (MOVE THE CODE TO DO THIS, MODIFIED, FROM GET1:)
; UPD ID= 59, SNARK:<5.EXEC>EXECP.MAC.16, 31-Aug-81 11:54:24 by CHALL
;TCO 5.1480 $CONT1- USE LABEL $CONF1 WHEN NOT 1ST TIME THROUGH
; UPD ID= 45, SNARK:<5.EXEC>EXECP.MAC.12, 19-Aug-81 10:39:22 by CHALL
;TCO 5.1464 .FORK- MOVE PROMPT TO EXECCA AND CHANGE FOR NOMFRK
;TCO 5.1465 .RESET- MOVE MFRK-DEPENDENT STUFF TO EXECCA
; UPD ID= 36, SNARK:<5.EXEC>EXECP.MAC.11, 14-Aug-81 19:12:56 by CHALL
;TCO 5.1454 CHANGE NAME FROM XDEF TO EXECDE
; UPD ID= 20, SNARK:<5.EXEC>EXECP.MAC.9, 21-Jul-81 12:29:22 by MURPHY
;TCO 5.1427 - Get rid of PNTMES in $GET2.
; UPD ID= 8, SNARK:<5.EXEC>EXECP.MAC.8, 13-Jul-81 17:40:46 by MURPHY
;TCO 5.1410 - OVER QUOTA, MACH SIZE EXCEEDED, ETC.
; UPD ID= 3, SNARK:<5.EXEC>EXECP.MAC.7, 9-Jul-81 18:09:57 by GRANT
;TCO 5.1405 - Do better analysis of fork termination in FRKTRM
; UPD ID= 2123, SNARK:<5.EXEC>EXECP.MAC.4, 4-Jun-81 09:51:25 by GRANT
;Add test for DSFF in ..STCR
; UPD ID= 1959, SNARK:<5.EXEC>EXECP.MAC.3, 7-May-81 11:36:02 by GROUT
;TCO 5.1317 - Make SET ADDRESS-BREAK work properly with AFTER parameter
;REMOVE MFRK CONDITIONALS
; UPD ID= 1740, SNARK:<6.EXEC>EXECP.MAC.3, 19-Mar-81 16:46:53 by OSMAN
;Make RUN FOO, ^C, DDT/USE-SECTION work
; UPD ID= 1626, SNARK:<6.EXEC>EXECP.MAC.2, 2-Mar-81 08:57:11 by OSMAN
;tco 6.1003 - Make "FOO text" pass itself to the program FOO as RSCAN data
;regardless of whether FOO is set as "KEEP CONTINUE" or "KEEP START".
;REMOVE MFRK CONDITIONALS
;<4.EXEC>EXECP.MAC.1, 29-Nov-80 16:57:40, Edit by DK32
;Programmable Command Language
; UPD ID= 1553, SNARK:<5.EXEC>EXECP.MAC.50, 11-Feb-81 10:00:38 by OSMAN
;More 5.1225 - Print ac's in octal
; UPD ID= 1551, SNARK:<5.EXEC>EXECP.MAC.49, 11-Feb-81 09:10:23 by OSMAN
;Make DDT/USE-SECTION work better (start DDT in correct section for one)
; UPD ID= 1472, SNARK:<5.EXEC>EXECP.MAC.48, 22-Jan-81 09:39:57 by OSMAN
;More 5.1225 - Don't set TRPOKF if there are errors
; UPD ID= 1438, SNARK:<5.EXEC>EXECP.MAC.47, 15-Jan-81 10:51:33 by OSMAN
;Tco 5.1233 - Make FILE-OPENINGS and JSYS OPENF independent
; UPD ID= 1417, SNARK:<5.EXEC>EXECP.MAC.46, 7-Jan-81 09:33:01 by OSMAN
;5.1225 - Fix error handling of programs bombing out
; UPD ID= 1416, SNARK:<5.EXEC>EXECP.MAC.45, 7-Jan-81 09:15:50 by OSMAN
;5.1225 again - Fix "CONTINUE fork", also don't set null traps
; UPD ID= 1415, SNARK:<5.EXEC>EXECP.MAC.44, 6-Jan-81 16:35:01 by OSMAN
; UPD ID= 1414, SNARK:<5.EXEC>EXECP.MAC.43, 6-Jan-81 16:09:13 by OSMAN
;Use .TFRAL before .TFSET
; UPD ID= 1413, SNARK:<5.EXEC>EXECP.MAC.42, 6-Jan-81 15:28:08 by OSMAN
;More 5.1225 - Handle case of fork not being us
; UPD ID= 1405, SNARK:<5.EXEC>EXECP.MAC.40, 6-Jan-81 13:42:29 by OSMAN
;Don't move "=>" (current fork) on CONTINUE command until confirmation
; UPD ID= 1400, SNARK:<5.EXEC>EXECP.MAC.39, 6-Jan-81 10:27:55 by OSMAN
;tco 5.1225 - Implement jsys trapping and file-opening trapping!
; UPD ID= 1324, SNARK:<5.EXEC>EXECP.MAC.38, 1-Dec-80 16:01:32 by OSMAN
;Use XSFRK% to start forks in non-0 sections
; UPD ID= 1269, SNARK:<5.EXEC>EXECP.MAC.37, 13-Nov-80 08:52:54 by OSMAN
; UPD ID= 1267, SNARK:<5.EXEC>EXECP.MAC.36, 12-Nov-80 14:04:50 by OSMAN
;Make "..34" be seen as a symbol and not a number
; UPD ID= 1265, SNARK:<5.EXEC>EXECP.MAC.35, 11-Nov-80 10:17:51 by OSMAN
; UPD ID= 1253, SNARK:<5.EXEC>EXECP.MAC.34, 10-Nov-80 13:24:31 by OSMAN
;Change routine CHKPAT to NOPAT, which skips if non-compatible
; UPD ID= 1244, SNARK:<5.EXEC>EXECP.MAC.33, 7-Nov-80 10:40:12 by FBROWN
;TCO 5.1192 - Make ADDNAM external so it can be called from EXECMI
; to give the MIC fork a name
; UPD ID= 1240, SNARK:<5.EXEC>EXECP.MAC.32, 6-Nov-80 15:20:52 by OSMAN
;TCO 5.1189 - Fix error on page numbers being out of order on SAVE.
;Add /USE-SECTION: on GET.
;Use HIGHPN instead of 377777
; UPD ID= 1207, SNARK:<5.EXEC>EXECP.MAC.31, 29-Oct-80 09:57:02 by OSMAN
;More 5.1168 - Get name right of defaultly kept
; UPD ID= 1202, SNARK:<5.EXEC>EXECP.MAC.30, 27-Oct-80 10:37:32 by OSMAN
;Put in SAV9: (only needed for .DIF file compatability)
; UPD ID= 1172, SNARK:<5.EXEC>EXECP.MAC.29, 20-Oct-80 09:32:58 by OSMAN
; UPD ID= 1171, SNARK:<5.EXEC>EXECP.MAC.27, 17-Oct-80 16:43:57 by OSMAN
; UPD ID= 1170, SNARK:<5.EXEC>EXECP.MAC.26, 17-Oct-80 16:12:44 by OSMAN
;More fix for SAVE confirmation
; UPD ID= 1149, SNARK:<5.EXEC>EXECP.MAC.25, 10-Oct-80 14:51:46 by OSMAN
; UPD ID= 1147, SNARK:<5.EXEC>EXECP.MAC.24, 10-Oct-80 10:57:02 by OSMAN
;Fix SAVE confirmation to print filespec
; UPD ID= 1133, SNARK:<5.EXEC>EXECP.MAC.23, 6-Oct-80 13:35:56 by OSMAN
;More 5.1168 - Use ETYPE instead of TYPE!
; UPD ID= 1131, SNARK:<5.EXEC>EXECP.MAC.22, 6-Oct-80 10:41:05 by OSMAN
;tco 5.1168 - Announce name of fork being kept
; UPD ID= 1130, SNARK:<5.EXEC>EXECP.MAC.21, 6-Oct-80 10:16:56 by OSMAN
;tco 5.1167 - Remove FDB autokeep feature
; UPD ID= 1115, SNARK:<5.EXEC>EXECP.MAC.20, 3-Oct-80 11:32:35 by OSMAN
;tco 5.1162 - Parse program names as keywords.
; UPD ID= 1043, SNARK:<5.EXEC>EXECP.MAC.19, 25-Sep-80 14:17:15 by OSMAN
;tco 5.1156 - Add SET DEFAULT PROGRAM
; UPD ID= 1030, SNARK:<5.EXEC>EXECP.MAC.18, 22-Sep-80 10:38:28 by OSMAN
;tco 5.1150 - Add SET PROGRAM
; UPD ID= 1020, SNARK:<5.EXEC>EXECP.MAC.17, 16-Sep-80 15:37:35 by OSMAN
;tco 5.1147 - Make sure ^C from INVOKE freezes fork
; UPD ID= 1014, SNARK:<5.EXEC>EXECP.MAC.16, 15-Sep-80 09:21:40 by OSMAN
;More 5.1129 - Calculate end of symbol table correctly
; UPD ID= 916, SNARK:<5.EXEC>EXECP.MAC.15, 19-Aug-80 14:05:38 by HESS
;Fix Examine/Deposit commands for multi-forking
; UPD ID= 900, SNARK:<5.EXEC>EXECP.MAC.14, 14-Aug-80 14:26:37 by OSMAN
;More 5.1129 - Handle large symbol tables better
; UPD ID= 883, SNARK:<5.EXEC>EXECP.MAC.13, 13-Aug-80 09:20:56 by OSMAN
;Make "ST,SIGNAL" not give horrible error if no program
; UPD ID= 872, SNARK:<5.EXEC>EXECP.MAC.12, 11-Aug-80 11:21:57 by OSMAN
;5.1129 - Allow "@" in instructions
; UPD ID= 867, SNARK:<5.EXEC>EXECP.MAC.11, 11-Aug-80 10:59:36 by OSMAN
;More 5.1129 - Handle "A,,B" and (gasp...) "A,,B(C)"
; UPD ID= 861, SNARK:<5.EXEC>EXECP.MAC.10, 10-Aug-80 16:06:07 by OSMAN
;More 5.1129 - Don't clobber P1 in EVAL
; UPD ID= 857, SNARK:<5.EXEC>EXECP.MAC.9, 10-Aug-80 15:20:17 by OSMAN
;tco 5.1129 - Add symbolic address and expression support
; UPD ID= 843, SNARK:<5.EXEC>EXECP.MAC.8, 6-Aug-80 08:55:19 by OSMAN
;TCO 5.1122 - Move setting of FK%BKG to WAITA so that entry from EXECCS hits it
; UPD ID= 831, SNARK:<5.EXEC>EXECP.MAC.7, 4-Aug-80 12:37:13 by LYONS
; DETACH (AND) CONTINUE USES A BEFOR IT HAS DATA
; UPD ID= 705, SNARK:<5.EXEC>EXECP.MAC.6, 26-Jun-80 10:13:03 by LYONS
;After running an ephemeron, tty mode is not reset as the exec wants
; UPD ID= 702, SNARK:<5.EXEC>EXECP.MAC.5, 26-Jun-80 09:40:48 by LYONS
;WEPHM calls FKTRM1 to tell why fork stoped, but B does not have the status
; UPD ID= 545, SNARK:<5.EXEC>EXECP.MAC.4, 21-May-80 12:07:28 by MURPHY
;Change XTND to MFRK for code related to multi-fork
;<5.EXEC>EXECP.MAC.3, 13-May-80 14:43:36, EDIT BY OSMAN
;Change "finished at" to "halted at"
;<4.1.EXEC>EXECP.MAC.2, 17-Mar-80 14:36:45, EDIT BY OSMAN
;Fix SPJFN arg setup (TMPJFN)
;<4.EXEC>EXECP.MAC.62, 26-Sep-79 16:05:36, Edit by HESS
; Fix filespec typeout on SAVE command (XTND only)
;<4.EXEC>EXECP.MAC.61, 24-Sep-79 12:19:29, Edit by HESS
; Disallow NAME<CR> as a valid command.
;<4.EXEC>EXECP.MAC.59, 20-Sep-79 14:13:56, Edit by HESS
; Use perm free space for FRKTBL
;<4.EXEC>EXECP.MAC.58, 18-Sep-79 14:26:48, Edit by HESS
; Change noise words of NAME command (XTND only)
;<4.EXEC>EXECP.MAC.57, 12-Sep-79 16:25:51, Edit by HESS
; Give warning if "forking" to inferior of inferior
;<4.EXEC>EXECP.MAC.56, 5-Sep-79 10:30:12, EDIT BY OSMAN
;tco 4.2440 - Avoid "?JFN is not assigned" in TV (Don't close jfns after GET
;jsys
;<HESS.E>EXECP.MAC.47, 20-Aug-79 17:56:49, Edit by HESS
; Add extended features
;<4.EXEC>EXECP.MAC.53, 21-Jun-79 13:37:07, EDIT BY OSMAN
;REMOVE EXTRANEOUS REFS TO RLJFNS
;<4.EXEC>EXECP.MAC.52, 19-Jun-79 16:16:48, EDIT BY OSMAN
;tco 4.2297 - Fix error message when trying to save execute-only program
;<4.EXEC>EXECP.MAC.51, 14-Jun-79 14:25:38, EDIT BY OSMAN
;TCO 4.2287 - Give good error if CONTINUE fails due to SFORK
;<4.EXEC>EXECP.MAC.48, 2-May-79 10:07:10, EDIT BY OSMAN
;GET RID OF CJFN1 (ASSUMED JFN WAS FIRST ON STACK, BAD ASSUMPTION!)
;<4.EXEC>EXECP.MAC.47, 30-Apr-79 13:19:13, EDIT BY OSMAN
;MAKE FORK CREATION ONLY DO EPCAP TO TURN OFF ^C
;<4.EXEC>EXECP.MAC.46, 27-Apr-79 16:37:31, EDIT BY OSMAN
;IF CHKPAT ENCOUNTERS ERROR, BOMB OUT
;<4.EXEC>EXECP.MAC.42, 27-Apr-79 15:30:06, EDIT BY OSMAN
;FIX CHKPAT, WHICH HAD TOO MANY POP'S
;<4.EXEC>EXECP.MAC.41, 20-Apr-79 10:01:00, EDIT BY OSMAN
;MAKE FAILING CFORK NOT SAY "JSYS ERROR AT"
;<4.EXEC>EXECP.MAC.39, 28-Mar-79 14:36:56, EDIT BY OSMAN
;tco 4.2226 - Don't save prog as "MACRO.EXE" after "CONTINUE STAY"
;<4.EXEC>EXECP.MAC.38, 19-Mar-79 11:40:13, EDIT BY DNEFF
;Fix ^C, START (or REENTER, etc) of compatible programs.
;<4.EXEC>EXECP.MAC.37, 12-Mar-79 18:02:17, EDIT BY KONEN
;UPDATE COPYRIGHT FOR RELEASE 4
;<4.EXEC>EXECP.MAC.36, 6-Mar-79 09:54:43, EDIT BY OSMAN
;USE GTJFS INSTEAD OF $GTJFN
;<4.EXEC>EXECP.MAC.35, 16-Feb-79 16:31:52, EDIT BY HEMPHILL
;TCO 4.2191 -- MAKE DDT COMMAND USE UDDT WHEN COMPATABILITY PACKAGE IS PRESENT
;<4.EXEC>EXECP.MAC.34, 31-Jan-79 11:02:35, EDIT BY OSMAN
;INCLUDE SS%WR IN SSAVE ARG
;<4.EXEC>EXECP.MAC.33, 30-Jan-79 17:24:18, EDIT BY OSMAN
;CALL SETPRG before RFORK at WAITA
;<4.EXEC>EXECP.MAC.32, 26-Jan-79 15:12:17, EDIT BY OSMAN
;REMOVE PRESERVE subcommand to SAVE, and make SAVE preserve by default
;<4.EXEC>EXECP.MAC.31, 15-Jan-79 23:00:28, EDIT BY HEMPHILL
;Patch CHKPAT to preserve save AC2 over calls to LOADF
;<4.EXEC>EXECP.MAC.30, 15-Jan-79 02:41:46, EDIT BY HEMPHILL
;MAKE EXEC UNDERSTAND USER EXTENDED ADDRESSING FOR INVOLUNTARY TERMINATION
; ALSO, MAKE "START" ACCEPT A LARGE ADDRESS, EVEN IF IT CAN'T USE IT YET
;<4.EXEC>EXECP.MAC.29, 12-Jan-79 17:36:32, EDIT BY OSMAN
;REMOVE REFS TO RUNFK
;<4.EXEC>EXECP.MAC.27, 8-Dec-78 16:31:50, EDIT BY OSMAN
;PUT IN SUBCOMMANDS TO SAVE COMMAND
;<4.EXEC>EXECP.MAC.26, 4-Nov-78 01:14:22, EDIT BY OSMAN
;tco 4.2077 - Make DDT command work after "fork" command
;<4.EXEC>EXECP.MAC.25, 18-Oct-78 14:40:59, EDIT BY OSMAN
;Improve message when program halts due to system call trap
;<4.EXEC>EXECP.MAC.24, 27-Sep-78 20:22:51, EDIT BY OSMAN
;REMOVE Bn SYMBOLS
;<4.EXEC>EXECP.MAC.18, 16-Sep-78 00:12:02, EDIT BY OSMAN
;REMOVE REFS TO CSBUFP
;<4.EXEC>EXECP.MAC.17, 14-Sep-78 14:10:35, EDIT BY OSMAN
;ONLY SEARCH XDEF, TTITLE DOES REST
;<4.EXEC>EXECP.MAC.15, 12-Aug-78 16:14:14, EDIT BY OSMAN
;CHANGE FAILING SAVES TO CALL OPNERR INSTEAD OF JRSTING TO IT
;<4.EXEC>EXECP.MAC.13, 29-Jun-78 13:10:23, EDIT BY OSMAN
;SAY NOT TOPS20 COMMAND LEVEL WHEN PROGRAM BEING RUN (FOR BATCH)
;<4.EXEC>EXECP.MAC.12, 27-Jun-78 11:22:28, EDIT BY OSMAN
;CHANGE PION/PIOFF TO CALL PION/CALL PIOFF
;<4.EXEC>EXECP.MAC.11, 26-Jun-78 14:10:29, EDIT BY OSMAN
;CLEAR CIPF INSTEAD OF COMAND AT WAITA
;<4.EXEC>EXECP.MAC.10, 13-Jun-78 11:28:04, EDIT BY OSMAN
;FIX PROBLEM WHERE "/RUN:FOO" FOLLOWED BY "G" IN EDIT SAT AND WAITED FOR
; SUPERFLUOUS CR
;<4.EXEC>EXECP.MAC.8, 9-Jun-78 18:36:57, EDIT BY OSMAN
;USE PION/PIOFF INSTEAD OF DIR/EIR
;<4.EXEC>EXECP.MAC.7, 24-May-78 09:57:11, EDIT BY OSMAN
;CLEAR STAYF, SO "REENTER" AFTER "CONTINUE STAY" DOESN'T STAY AT @ LEVEL
;<4.EXEC>EXECP.MAC.6, 2-Mar-78 09:06:18, Edit by PORCHER
;<4.EXEC>EXECP.MAC.5, 2-Mar-78 08:52:46, Edit by PORCHER
;Add SETGO routine for CCL start (in EXECCS)
;<4.EXEC>EXECP.MAC.4, 31-Jan-78 15:17:16, Edit by PORCHER
;<4.EXEC>EXECP.MAC.3, 30-Jan-78 17:02:41, Edit by PORCHER
;<4.EXEC>EXECP.MAC.2, 30-Jan-78 14:59:14, Edit by PORCHER
;Add changes for execute-only
;<4.EXEC>EXECP.MAC.1, 7-Jan-78 15:18:31, EDIT BY HELLIWELL
;ADD HELP TEXT TO OCTX AT .START+5
;TOPS20 'EXECUTIVE' COMMAND LANGUAGE
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1980,1981,1982 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
SEARCH EXECDE
TTITLE EXECP
;THIS FILE CONTAINS PROGRAM COMMANDS, LIKE RESET, CONTINUE, RUN, R ETC.
DEFINE CONSTG
< TRVAR <UFORK,FTW,TMPJFN,SJBUFP> ;;COMMON STORAGE FOR CONTINUE, START
;; COMMANDS
SETZM TMPJFN> ;INITIALLY NO JFN
;BITS AND FIELDS DEFINED IN OPLIST:
OP%SC==1B0 ;SUBROUTINE CALL INSTRUCTION
OP%TRN==1B1 ;INSTRUCTION POSSIBLY TRANSFERS TO SOMEWHERE
OP%SKP==1B2 ;INSTRUCTION SKIPS
OP%CB==1B3 ;CONDITIONAL BRANCH
OP%RET==1B4 ;SUBROUTINE RETURN
OP%US==1B5 ;UNCONDITIONAL SKIP
OP%NAM==777777B35 ;ADDRESS OF ASCIZ NAME OF OPCODE
;FIELDS FOR SYMBOL NAME WORD
SCFLD==17B3 ;LEFT FOUR BITS ARE TYPE OF SYMBOL
SCGLB==4B5 ;IF THIS BIT ON, SYMBOL IS GLOBAL
SCLCL==10B5 ;LOCAL
SCHIDE==40B5 ;HIDE THIS SYMBOL FROM PRINTOUT
SNFLD==-1-SCFLD ;REST IS NAME OF SYMBOL
;RESET
.RESET::JRST .RESST ;START OFF THE RESET (IN EXECCA)
.RESS1::CAIE A,"*" ;WANT TO RESET ALL?
JRST [SKIPG A,FORK ;NO - TRY CURRENT
ERROR <No program>
TMNE FK%INV,SLFTAB(A) ;715 current fork was INVOKE'd?
ERROR <No program> ;715 yes, don't reset 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)
NOP
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) ;715 Current fork was INVOKE'd?
JRST RESET2 ;715 Yes, don't reset it
HLRZ B,@SLFTAB(A) ;GET HANDLE
CAIE B,.FHSLF ;IS THIS US
JRST [MOVEI A,(B) ;NO - KEEP LOOKING
JRST RESET1]
MOVX B,FK%INT ;NO LONGER INTERRUPTED
ANDCAM B,SLFTAB(A) ;CLEAR IT
RESET2: CALL ERESET ;7 modify to select new fork
;7 CALLRET ERESET ;KILL OFF FORK AND RETURN
CALLRET NXTFRK ;7 select next fork
.RESE2::
;7 CALL FRKNM0 ;GOBBLE NAME OR SOMETHING
CONFIRM
CALL FRKNM0 ;7 confirm before decoding fork, and possible
;7 warning msg, which requires another confirm
.RESE3: PUSH P,A ;SAVE HANDLE
CALL PIOFF ;DISABLE INTERRUPTS
CALL FREL
POP P,A ;RESTORE HANDLE
CALL KEFORK ;KILL IT OFF
CALL PION ;7 modify to select new fork
;7 CALLRET PION ;TURN THE WORLD BACK ON AND RETURN
CALLRET NXTFRK ;7 select next fork
;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.
NOP ;UNMAP SHOULDN'T FAIL
; CALL PIOFF ;DON'T ALLOW ^C WHILE IN FUNNY STATE
SETO A, ;UNMAP SYMBOL TABLE WINDOW
LDB B,[PAGENO SYMBF] ;GET PAGE NUMBER OF WINDOW
HRLI B,.FHSLF ;UNMAP FROM OUR ADDRESS SPACE
MOVX C,PM%CNT!FLD(NSMPGS,PM%RPT) ;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!FK%UND ;7 add under debugger ;715 invoked
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
ERNOP
MOVE Q1,FRKTAB(Q2) ;FLAGS
MOVEI A,.FHSLF(Q2) ;FORK HANDLE
CALL DELNAM ;DELETE NAME IF ANY
HRRZ B,FRKTAB(Q2) ;BLOCK ADDRS
MOVX 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
KEFOR0::ATSAVE ;7 save ACs entry
KEFORK::SKIPN Q1,SLFTAB(A)
JRST KEFRK2 ;NON-EX FORK
CALL DELNAM ;REMOVE NAME FROM TABLE
HLRZ B,(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,(Q1) ;INFERIOR HANDLE
PUSH P,A ;SAVE IT
HRRZ B,Q1 ;ADDRS OF BLOCK
MOVX 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
ERJMP [RFRKH ;7 failed, try to release it
ETYPE < %%Couldn't kill fork%_> ;7 failed again
JRST .+1] ;7
;7 ERCAL [ETYPE <%%Process disappeared%_>
;7 RET] ;RETURN NOW
CAMN A,FORK ;CURRENT FORK
SETOM FORK
CAMN A,RUNFK ;RUNNING FORK
SETOM RUNFK
CAMN A,EDFORK ;EDITOR FORK
SETOM EDFORK
;7 CAMN A,IDFORK ;IDDT FORK
;7 SETOM IDFORK
MIC,< CAMN A,MICFRK ;MIC HERE
SETOM MICFRK
>
MOVE B,[-2] ;715 special uninitialized value
CAMN A,PCFORK ;715 saved copy of FORK from INVOKE?
MOVEM B,PCFORK ;715 yes, we don't want to restore this value
;715 to FORK later
CAMN A,PCRNFK ;715 saved copy of RUNFK from INVOKE?
MOVEM B,PCRNFK ;715 yes, we don't want to restore this value
RET
;STEP TO NEXT FORK
NXTFRK: MOVX A,NFRKS-1 ;LOOK THRU TABLE
NXTFR1: SKIPN FRKTAB(A) ;EXISTS?
JRST NXTFR2 ;NO - TRY NEXT
MOVE B,FRKTAB(A) ;715 get fork flags
TXNE B,FK%INV ;715 INVOKE'd fork?
JRST NXTFR2 ;715 yes, don't select 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,FRKDES ;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,FRKDES(A) ;FORK NUMBER ONLY
ETYPE <[Fork %2O]>
RET ;RETURN
NXTFR5: SETOB A,FORK ;NO CURRENT FORK
RET
;ROUTINE TO DELETE A FORK NAME
;
; ACCEPTS: A/ FORK HANDLE
; Q1/ FRKTAB ENTRY
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
SETZ C, ;7 delete it from FRKNMS
;7 TXNE C,FN%NAT ;ARE THERE ATTRIBUTES TO THIS NAME?
;7 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!)
;7 C/ table to use: 0:FRKNMS #0:PRGNMS
DELFBK: STKVAR <STA,FBA,DFBKF> ;7 add DFBKF
MOVEM C,DFBKF ;7 store which table
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
MOVX 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
SKIPE DFBKF ;7 do we want to get the PRGNMS entry?
MOVEI A,PRGNMS ;7 yes
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
;
; ACCEPTS: A/ FORK HANDLE
; B/ POINTER TO ASCIZ FORK NAME
ADDNAM::STKVAR <AFORK,ENPTR,AUGMNT,NAMPTR>
MOVEM A,AFORK ;SAVE HANDLE
MOVE A,CSBUFP ;WRITE NAME INTO SOME SCRATCH SPACE
SETZ C, ;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
MOVX C,FLD(^D10,NO%RDX) ;INCREMENT NAMES IN DECIMAL
NOUT ;FORM NEW NAME
CALL JERR ;SHOULDN'T FAIL!
JRST ADDNM2 ;GO SEE IF THIS MODIFIED NAME IN TABLE
;COME HERE WHEN THE NAME IS FOUND IN THE TABLE BUT NO REAL FORK IS CURRENTLY
; ASSOCIATED WITH THE NAME.
ADDNM4: MOVE B,AFORK ;NO, SO USE THIS SLOT
STOR B,FKHAN,(C)
HLRZ B,(A) ;GET ADDRESS OF PROGRAM NAME
MOVEM B,.FKNAM(Q1) ;REMEMBER NAME OF THIS PROGRAM
ADDNM5: MOVE A,AFORK ;GET HANDLE OF FORK THAT MAY NEED KEEPING
LOAD D,FKFLAG,(C) ;GET FLAGS ABOUT THIS NAME
MOVE B,SLFTAB(A) ;SEE IF FORK IS ALREADY KEPT
TXNE B,FK%KPT ;7 simplify this process
;7 TXNN B,FK%KPT ;IF SO, CALL ANNKEP TO PUT NAME IN KEPNMS
;7 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 GETDEF ;7 install SET PROGRAM defaults
;7 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
;7 install SET PROGRAM block for this fork, or if none use DEFAULT
GETDEF: TRVAR <DEFLOC> ;7 location of SET PROG block
MOVEI A,PRGNMS ;7 find SET PROGRAM block
MOVE B,COMAND ;7 get unaugmented fork name
TBLUK ;7
TXNN B,TL%EXM ;7 is there a SET PROGRAM block?
JRST GETFBK ;7 no, copy default block to fork block
HRRZ A,(A) ;7 get the address of SET PROGRAM block
MOVEM A,DEFLOC ;7
CALL GETFB1 ;7 get the fork block
HRL B,DEFLOC ;7 copy SET PROGRAM block to the fork block
HRR B,A ;7
BLT B,FKTLEN-1(A) ;7
RET ;7
;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::MOVX 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
ANNKP0::ATSAVE ;7 save ACs entry
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
TXOE C,FK%KPT ;7 modify to work with noisy forks flag
;7 TXON C,FK%KPT ;KEEP FORK AND ANNOUNCE IF THIS IS NEWS
JRST ANNKP1 ;7
SKIPE NOISY ;7 are we allowed to say something?
ETYPE <[Keeping %2M]%_> ;7 yes
ANNKP1: MOVEM C,SLFTAB(A) ;7 add local label
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,FLD(.JSAOF,JS%NAM) ;FILE NAME
JFNS
MOVE A,SFKFRK ;GET FORK HANDLE
MOVE Q1,SLFTAB(A) ;TABLE ENTRY
CALL DELNAM ;REMOVE ANY EXISTING NAME
LDB C,[FIRCHR SFKBUF] ;GET FIRST CHAR
JUMPE C,R ;NULL - EXIT
HRROI B,SFKBUF
JRST ADDNAM ;GO ADD NAME
;REENTER
; DECODE AND CHECK SUBROUTINE ALSO USED BY REDIRECT/DETACH
$REENT::SKIPGE A,FORK
ERROR <No program>
CALL GETENT ;GET ENTRY VECTOR
CAIGE B,2 ;LONG ENOUGH TO HAVE REENTER?
ERROR <No REENTER address>
RET
;REENTER COMMAND DISPATCHES HERE
.REENT::NOISE <program>
CONFIRM
REENT1: SETZM STAYF ;DON'T STAY AT COMMAND LEVEL (UNTIL "REENTER
; STAY" IMPLEMENTED!)
CALL $REENT
;REDIRECT/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
MOVX B,1 ;ENTRY VECTOR INDEX 1 FOR REENTER
JRST ..STCR ;CONTINUE BELOW AND START PROCESS
;CONTINUE
; RESUMES FROZEN INFERIOR FORKS
;"CONTINUE" COMMAND DISPATCHES TO HERE
.CONTI::CALL .CONT1 ;PARSE COMMAND
CALL $CONTI ;SET FORK
JRST ..CONT ;RESUME PROCESS
.CONT1: NOISE <fork>
CONSTG ;ALLOCATE STORAGE
SETZM STAYF
MOVE A,FORK ;CONTINUE CURRENT FORK UNLESS OTHERWISE
; SPECIFIED
MOVEM A,UFORK ;USE UFORK UNTIL CR SEEN FOR CONFIRMATION
.CONT2: MOVEI B,$CONFD ;APPROPRIATE FIELD DESCRIPTORS
TLOE Z,F1 ;FIRST TIME THRU?
MOVEI B,$CONF1 ;NO - ONLY ALLOW COMMA OR CR
CALL FLDSKP ;PARSE LINE
CMERRX
GTFLDT D ;GET FUNCTION CODE
CAIN D,.CMCFM ;CR?
JRST CONU ;YES - CHECK MODES
CAIN D,.CMCMA ;COMMA SEEN?
JRST .CONT3 ;YES - CHECK SUBCOMMANDS
CAIN D,.CMKEY ;KEYWORD?
JRST [MOVE D,.CMDAT(C) ;YES - SEE WHICH ONE
CAIN D,$CMODE ;MODE KEYWORD?
JRST CONC1 ;YES
GTFLDT D ;NO, MUST BE FORK. RESTORE D
JRST .+1]
SETOM SVAL0 ;7 not direct inferior handled later
CALL FRKNM0 ;PARSE NAME OR NUMBER
MOVEM A,UFORK ;SAVE HANDLE (DON'T TOUCH "FORK" CELL UNTIL
; CONFIRMATION!)
JRST .CONT2 ;LOOK FOR CR OR COMMA
.CONT3: CRRX <Carriage return to enter subcommands>
JRST .CONT4
SUBCOM $PMODE ;GET PROGRAM MODES
CONU: MOVE A,UFORK ;ONLY CHANGE "FORK" NOW THAT COMMAND IS
; CONFIRMED
MOVEM A,FORK
MOVX B,FK%RUN
TDNE B,SLFTAB(A) ;RAN THIS ONE?
MOVEM A,RUNFK ;YES - STORE IN RUNFK
JRST .CONT5
.CONT4: KEYWD $PMODE ;LOOK UP A MODE IF NO CR GIVEN
0 ;NO DEFAULT
CMERRX
CALL (P3) ;DISPATCH
.CONT5: SKIPG A,FORK ;DO WE HAVE A FORK
ERROR <No program>
CALL OURFRK ;7 is it a direct inferior?
SKIPN D,SLFTAB(A) ;7 is this a known fork? (use AC D)
RET ;7 no, we don't fool with it
MOVE Q1,TMPJFN ;7 move new JFNs
TXNN D,FK%BKG!FK%TTY ;7 fooling with a background fork?
JRST .CONT6 ;7 no
TXZ D,FK%BKG ;7 zap background flag
MOVE B,.FKPTM+TTWPTI(D) ;7 restore TTY interrupt word
STIW ;7
;7 SKIPE Q1,TMPJFN ;SUBCOMMANDS RETURN HERE
;7 JRST .CONT6 ;DON'T FIDDLE PRIMARY JFNS
;7 SKIPE B,SLFTAB(A) ;KNOWN FORK
;7 TXNN B,FK%BKG!FK%TTY ;BACKGROUND OR TTY WAITER
;7 JRST .CONT7 ;NO FORK, OR NOT BACKGROUND
;7 MOVX B,FK%BKG
;7 ANDCAM B,SLFTAB(A) ;CLEAR BACKGROUND FLAG
.CONT6: MOVX A,.FHSLF ;SEE WHAT WE HAVE FOR JFNS
GPJFN
MOVE A,FORK ;GET FORK HANDLE BACK
TLNN Q1,-1 ;7 modify to save process TIW
;7 MOVE D,SLFTAB(A) ;GET ITS FLAGS
;7 TLNE Q1,-1 ;WANT TO CHANGE PRIMARY INPUT?
JRST .CON6A ;7 no
PUSH P,B ;7 yes, save process TIW
RTIW ;7
MOVEM B,.FKPTM+TTWPTI(D) ;7
POP P,B ;7
SKIPE STAYF ;7 set background flag
TXO D,FK%BKG ;7
TXOA D,FK%PRI ;YES - SET FLAG
.CON6A: ;7 add local label
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
TXZ D,FK%INT!FK%TTY ;7 turn these off
MOVEM D,SLFTAB(A) ;UPDATE FLAGS
MOVE B,Q1 ;JFNS TO B
;7 MOVE A,FORK ;FORK TO A
SPJFN ;SET PRIMARY JFNS
;7.CONT7:SKIPN SLFTAB(A) ;KNOW THIS FORK?
;7 RET ;NO - DONE
;7 MOVX B,FK%INT
;7 ANDCAM B,SLFTAB(A) ;CLEAR INTERRUPTED BIT
RET ;RETURN
;SUBCOMMAND TABLE AND ROUTINES
$PMODE: TABLE
T background
T input,,.CINPU
T no,,.CNO
T output,,.COUTP
T quiet,,.CQUIE
T signal,,.CSIGN
T stay
TEND
;HANDLE "STAY" OR "NORMALLY" AS KEYWORD ON CONTINUE LINE
CONC1: CONFIRM
HRRZ C,(B) ;GET ROUTINE ADDRESS
HRRZ C,(C)
CALL (C) ;DO IT
JRST CONU ;FINISH UP
$CMODE::TABLE
T normally,,..NORM
T stay,,..STAY
TEND
..NORM: SETZM STAYF ;I.E. NO STAY
RET
;REDIRECT OUTPUT TO FILE
.COUTP: NOISE <to file>
SETZ A,
CALL COUTFN ;GET OUTPUT FILE NAME
JRST CERR
CONFIRM
MOVX B,OF%WR ;OPEN FOR WRITE
CALL $OPEN7
JRST .CSIGO ;STORE JFN AND RETURN
;GET INPUT FROM FILE
.CINPU: NOISE <from file>
MOVX B,(GJ%OLD!GJ%MSG) ;7 put the bits in the right place
;7 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
MOVX A,.NULIO ;SET NULL JFN
HRRM A,TMPJFN ;FOR OUTPUT
JRST .CBAC2 ;SET INPUT JFN FOR TRAP
;STAY AT COMMAND LEVEL
.STAY: CONFIRM
JRST ..STAY
;SIGNAL TTY I/O
.CSIGN: NOISE <when TTY wanted for>
SKIPA A,[.SIGIO] ;CAUSE PRIMARY TRAP
.CNO: MOVX A,.NULIO ;NULL DEVICE
.CSIG2: KEYWD $CSIGN
T either,,.CSIGB ;DEFAULT TO EITHER
JRST CERR
CONFIRM
JRST (P3) ;DISPATCH
$CSIGN: TABLE
T either,,.CSIGB ;SIGNAL BOTH
T input,,.CSIGI ;SIGNAL INPUT
T output,,.CSIGO ;SIGNAL OUTPUT
TEND
.CSIGB: CALL .CSIGI ;SET INPUT
.CSIGO: HRRM A,TMPJFN ;SET OUTPUT JFN
JRST ..STAY ;RETURN
;SET BACKGROUND MODE
.BACKG: CONFIRM
.CBAC2: MOVX A,.SIGIO ;SET FOR INPUT TRAP
.CSIGI: HRLM A,TMPJFN ;SET PRIMARY INPUT
..STAY: SETOM STAYF ;STAY AT COMMAND LEVEL
RET ;EXIT
DEFINE PRSTG ;LOCAL STORAGE FOR "SET PROGRAM"
< TRVAR <DEFF,IINFO,STRA,PNM>>
;SET DEFAULT PROGRAM <ATTRIBUTE>
; ASSIGNS DEFAULT ATTRIBUTES, USED IN LIEU OF SET FILE ATTRIBUTES, IF NO
; "SET PROGRAM" OVERRIDES IT.
SDPROG::PRSTG ;GET LOCAL STORAGE
SETOM DEFF ;SAY WE'RE DOING DEFAULTS
JRST PROG1 ;USE SAME CODE AS "SET PROGRAM"
;SET NO DEFAULTS (FOR) PROGRAM
SNDPRG::PRSTG ;GET LOCAL STORAGE
SETOM DEFF ;SAY THIS IS DEFAULT
SNPRG1: CALL PBLK ;POINT AT BLOCK
SETZRO FKFLAG,(A) ;CLEAR DEFAULTS
RET
;SET PROGRAM <NAME> <ATTRIBUTE>
; ASSIGNS ATTRIBUTES TO FORKS OF THE SPECIFIED NAME
PROG:: PRSTG ;GET LOCAL STORAGE
SETZM DEFF ;SAY NOT SETTING DEFAULTS
NOISE <name>
WORDX <Fork name>
CMERRX <Invalid fork name>
CALL BUFFF ;BUFFER THE NAME
MOVEM A,PNM ;REMEMBER IT
PROG1: NOISE <attribute>
KEYWD PROGA ;READ ATTRIBUTE
0 ;NO DEFAULT
CMERRX ;STANDARD ERROR IF BAD KEYWORD TYPED
CALLRET (P3) ;EXIT THROUGH SPECIFIED PLACE
PROGA: TABLE ;TABLE OF ATTRIBUTES
T ephemeral,ONEWRD,PEPH ;SET PROGRAM NAME EPHEMERAL
T keep,,PKEEP ;SET PROGRAM NAME KEEP (AND)...
IT no-ephemeral,,PNEPH ;SET PROG NAME NO-EPHEMERAL
T none,ONEWRD,PNONE ;UNDO ANY PREVIOUS SET PROGRAM
T unkept,,PNEPH ;7 easier to understand
TEND
PNEPH: CALL RSTPRG ;7 restructure code
;7 CONFIRM
;7 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
MOVE B,IINFO ;GET POINTER TO KEYWORD
CALLRET RSTINS ;7 save some code
;7 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,PRGNMS ;7 use PRGNMS instead of FRKNMS
;7 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
SETO C, ;7 use PRGNMS table for DELFBK
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,,[..CONT
[ASCIZ/Continuing/]]
T reenter,,[REENT1
[ASCIZ/Reentering/]]
T start,,[SAD: .STRT1
[STMES: ASCIZ/Starting/]]
TEND
;SET PROGRAM NAME KEEP (AND) ACTION (WHEN INVOKED AS A COMMAND)
PKEEP: CALL RSTPRG ;7 restructure code
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
CALLRET RSTINS ;7 restructure code
;7 this code moved from PKEEP into seperate subroutine for use with .STRES
RSTPRG: NOISE <and>
HELPX <how to lazy-restart program> ;7 jargon
;7 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 lazy-restarted> ;7 jargon
;7 NOISE <when invoked as a command>
CONFIRM
CALLRET PBLK ;GET NAME BLOCK FOR SPECIFIED FORK
;7 this code moved from PKEEP into seperate subroutine for use with .STRES
RSTINS: STOR B,FKRESP,(A) ;REMEMBER FOR "INFO PROG" COMMAND
MOVE B,(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
RET
;7 SET RESTART (TO) <restart type> (FOR FORK) <fork name>
.STRES::STKVAR <SRSPE,SRSPD> ;7 set program entry addr, set program data
NOISE <to> ;7
KEYWD PROGK ;7 get restart type: start, continue, reenter
0 ;7
CMERRX ;7
HRLO A,(B) ;7
MOVEM A,SRSPE ;7 save address of SET PROGRAM entry
MOVEM P3,SRSPD ;7 save p3 (SET PROGRAM data)
NOISE <for fork> ;7
MOVEI B,$FRKNM ;7 get fork name, number, or CR (current fork)
CALL FLDSKP ;7
CMERRX ;7
GTFLDT D ;7 type of parse
CAIE D,.CMCFM ;7 CR?
JRST SETRS0 ;7 no
CALL CURFB ;7 yes, find address of current fork block
JRST SETRS2 ;7
SETRS0: CONFIRM ;7 confirm for number or name
CAIE D,.CMKEY ;7 name?
JRST SETRS1 ;7 no
HRRZ A,(B) ;7 yes, get fork block address in A
ABSKP ;7
SETRS1: CALL NUMFB ;7 a fork number
SETRS2: MOVE B,SRSPE ;7
MOVE P3,SRSPD ;7
CALLRET RSTINS ;7
;7 handle current fork's fork block
CURFB: HLRZ D,FRKNMS ;7 number of forks in D
CAIE D,0 ;7 no forks
SKIPG A,FORK ;7 no current fork, load A with fork handle
ERROR <No current fork> ;7
CURFB2: MOVX B,1 ;7 index for table in B
CURFB0: MOVE C,FRKNMS(B) ;7
HRRZ C,C ;7 get fork block address in C
ADDI C,1 ;7 add fork handle offset
CAMN A,(C) ;7 fork handles equal?
JRST CURFB1 ;7 yes
ADDI B,1 ;7 increment index
CAMG B,D ;7 larger than number of forks
JRST CURFB0 ;7 LOOP
ERROR <Invalid fork> ;7
CURFB1: SUBI C,1 ;7 get fork block address back
MOVE A,C ;7
RET ;7
;7 handle fork block selected by fork number
NUMFB: MOVEI A,FRKDES(B) ;7 make a fork handle
HLRZ D,FRKNMS ;7 number of forks in D
CAIN D,0 ;7
ERROR <No forks> ;7 there are no forks
JRST CURFB2 ;7 look around for this fork
;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,PRGNMS ;7 use PRGNMS instaed of FRKNMS
;7 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,PRGNMS ;7 use PRGNMS instead of FRKNMS
;7 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,77700 ;DISTINGUISH -1 FROM 0-5,400000-400005
ERROR <Program disappeared> ;-1 = UNASSIGNED HANDLE.
RET
;COMMON ROUTINE TO START/RESTART AN EXISTING FORK
;
; ACCEPTS: B/ FRKNMS ENTRY
RSTFK:: CONSTG ;ALLOCATE STORAGE
HRRZ B,(B) ;GET FORK TABLE ADDRESS
MOVEM B,FTW ;REMEMBER FORK BLOCK ADDRESS
LOAD A,FKHAN,(B) ;GET FORK HANDLE FROM TABLE
MOVEM A,FORK ;SET TO CURRENT FORK
SETZM STAYF
CALL .CONT5 ;COMMON SETUP
MOVEM A,RUNFK ;SET AS CURRENT RUNNING FORK
MOVX B,FK%RUN
;7 default is to CONTINUE when restarting unkept fork
;7 MOVE C,FTW
;7 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 C,FKRADD,(B) ;7 get restart address
CAIN C,0 ;7 is there a one?
JRST ..CNT0 ;7 no, just continue
LOAD A,FKRMES,(B) ;GET POINTER TO MESSAGE
DOMES: ETYPE <[%1M]%_> ;PRINT APPROPRIATE RESTART MESSAGE
MOVE A,C ;7 already have this info
;7 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
..CNT0::ETYPE <[Continuing]%_> ;7 print message entry
..CONT::MOVE A,RUNFK ;LAST RUN FORK
TXO A,SF%CON ;SET "CONTINUE" BIT
SFORK ;CONTINUE PROCESS FROM HALT
ERCAL CJERRE ;FAILED, TELL USER WHY (PROBABLY NEVER
; STARTED!)
;WHEN THE PROGRAM IS RUNNING WE DON'T WANT THE EXEC TO HAVE ANY OF ITS PAGES
; MAPPED. HENCE CLEAR THE PAGE BUFFER:
CALL SETGO ;SET UP FOR PROGRAM RUNNING
CALL PIOFF ;DON'T ALLOW ^C WHILE IN FUNNY STATE
CALL FREL ;RUNNING FORK MAY CHANGE SYMBOL TABLE, SO CLEAR
; DATABASE
CALL PION ; HANDLE AGAIN; ALLOW ^C
MOVE A,RUNFK
JRST WAITR ;GO RESUME FORK AND WAIT FOR IT
;"DDT" COMMAND. LOAD DDT IN INFERIOR FORK IF NECESSARY, TRANSMIT SYMBOL TABLE
; POINTER, START DDT.
.DDT:: TRVAR <DDTSEC,JBSYM,JBBUSY,SA,PRGSEC>
CALL GSWIS ;PARSE POSSIBLE SWITCHES
JUMPL A,[SKIPG B,FORK ;IF NO SPECIAL SECTION, IS THERE A FORK?
JRST .+1 ;NO FORK AND NO SPECIAL SECTION, LEAVE AS -1.
HRRZ C,SLFTAB(B) ;NO SPECIAL SECTION BUT THERE IS A FORK
MOVE A,CODSEC(C) ;USE CODE SECTION FOR DDT'S
JRST .+1]
MOVEM A,DDTSEC ;SAVE SECTION TO PUT DDT IN
SETZM STAYF
SETZM JBSYM
SETZM JBBUSY ;CLEAR SYMBOL DATA
SKIPLE A,FORK ;7 make sure its our inferior
CALL OURFRK ;7
SKIPLE A,FORK ;CURRENT FORK?
SKIPN A,SLFTAB(A) ;YES - KNOWN?
JRST DDT2 ;NO FORK - JUST GET DDT
TXNE A,FK%KPT ;7 warn if fork is kept
JRST [ETYPE < %%Fork is KEPT%_> ;7
CALL GOAHED ;7 do it anyway?
JRST .+1] ;7
TXNE A,FK%DDT ;DDT PRESENT IN THIS FORK?
JRST DDT4 ;YES - JUST START IT
SETZM PRGSEC ;FIRST ASSUME NO PROGRAM SECTION SPECIFIED
SKIPL A,CODSEC(A) ;IS THERE ONE?
MOVEM A,PRGSEC ;YES, REMEMBER IT
;THERE IS A FORK, SEE IF IT ALREADY CONTAINS SOMETHING THAT LOOKS LIKE A DDT.
; IF SO, LEAVE IT, AS IT MAY CONTAIN BREAKPOINTS, MODIFIED SYM TAB PTR, ETC.
MOVEI A,DDTORG ;DDT BEGINNING ADDRESS
HRL A,PRGSEC ;LOOK IN CORRECT SECTION
CALL MAPPF
JRST CJERRE ;FAILED-- TYPE JSYS ERROR
TXNN B,PA%PEX ;PAGE EXISTS?
JRST DDT1 ;NO, FORK DOESN'T HAVE DDT
ANDI A,777 ;LINE ONLY
MOVE A,PAGEN(A) ;LOAD FIRST WORD
CAMN A,[JRST DDTORG+2]
JRST DDT3 ;ALREADY HAVE ACCEPTABLE DDT
;FORK DOESN'T HAVE UDDT - SEE IF THERE'S SOME OTHER DEBUGGER OR IF NOT THEN SEE
; IF THERE IS A SYMBOL TABLE PNTR
DDT1: MOVEI A,JOBDDT ;LOC FOR DEBUGGER ADDRS
HRL A,PRGSEC ;USE APPROPRIATE SECTION
CALL MAPPF ;MAP PAGE OF FORK
JRST CJERRE ;FAILED-- TYPE JSYS ERROR
TXNE B,PA%PEX ;NO PAGE?
TXNN B,PA%RD ;READ PROTECT?
JRST DDT2 ;NO USEABLE PTR
HRRZ A,PAGEN(A) ;SEE IF ALREADY HAVE START ADDRS
JUMPG A,[MOVEM A,SA ;YES, SAVE IT
JRST DDT5] ;AND JOIN COMMON CODE
MOVEI A,JOBSYM&777 ;PNTR TO SYMBOL TABLE
MOVE C,PAGEN(A) ;FETCH SYM TAB PTR WORD
;IF NEGATIVE, IT WILL BE ASSUMED TO BE PTR
MOVE D,PAGEN+1(A) ;.JBUSY IS JOBSYM+1
;NO CHECKING NEEDED, DDT WILL FIX IT UP.
MOVEM C,JBSYM ;REMEMBER SYMBOL POINTER
MOVEM D,JBBUSY ;REMEMBER OTHER WORD (WHAT IS IT?)
DDT2: SKIPGE JBSYM ;SYMBOL TABLE POINTER?
JRST DDT6 ;YES, GO USE UDDT
SKIPGE A,FORK ;GET HANDLE ON CURRENT FORK
JRST SDDT ;NONE, SO USE SDDT
GCVEC ;IS PA1050 PRESENT?
JUMPG B,DDT6 ;PA1050 PRESENT--USE UDDT
SDDT: SKIPA B,[ASCPTR [GETSAVE <SYS:SDDT.>]] ;DDT WITH SYMBOLS
DDT6: MOVE B,[ASCPTR [GETSAVE <SYS:UDDT.>]]
;DDT...
;LOAD SELECTED DDT
MOVX A,GJ%OLD!GJ%SHT ;SET UP FOR OLD-FILE AND SHORT FORM GTJFN
CALL GTJFS ;GET AND STACK THE JFN
CALL CJERRE ;IF FAILS, JUST PRINT ERROR
MOVE B,DDTSEC ;PASS -1 OR SECTION TO MERGE ROUTINE
CALL $MERGE ;MERGE IT INTO FORK, CREATING FORK IF NONE, AND
; RELEASE JFN
;STORE SYMBOL TABLE POINTER
SKIPL JBSYM ;SYMBOL POINTER?
JRST DDT3 ;NO
MOVEI A,DDTSYM
SKIPL DDTSEC ;USE SPECIAL SECTION IF GIVEN
HRL A,DDTSEC
HLL Q1,A ;REMEMBER SECTION
CALL MAPPF
JRST CJERRE ;FAILED-- TYPE JSYS ERROR
ANDI A,777
HRR Q1,PAGEN+1(A) ;WHERE TO STORE UNDEF PTR
HRRZ A,PAGEN(A) ;POINTER TO WHERE TO PUT POINTER
SKIPL DDTSEC ;USE DDT SECTION IF SPECIAL
HLL A,Q1 ;SAY WHICH SECTION TO LOOK IN
CALL MAPPF
JRST CJERRE ;FAILED-- TYPE JSYS ERROR
ANDI A,777
MOVE C,JBSYM
MOVEM C,PAGEN(A) ;STORE POINTER
MOVE A,Q1 ;WHERE TO PUT UNDEF PTR IN DDT
CALL MAPPF
JRST CJERRE ;FAILED-- TYPE JSYS ERROR
ANDI A,777
MOVE D,JBBUSY
MOVEM D,PAGEN(A) ;STORE OTHER WORD (WHAT IS IT?)
DDT3: SKIPLE A,FORK ;HAVE FORK?
SKIPN B,SLFTAB(A)
JRST DDT4 ;NOPE - JUST START
MOVX B,FK%DDT ;YES - MARK DDT PRESENT
IORM B,SLFTAB(A)
HRRZ A,SLFTAB(A) ;GET ADDRESS OF FORK DATA
MOVEI B,DDTORG ;GET START ADDRESS OF DDT
SKIPL DDTSEC
HRL B,DDTSEC ;GIVE IT CORRECT SECTION
MOVEM B,DDTSA(A) ;REMEMBER DDT'S START ADDRESS
;TRANSFER CONTROL TO DDT
DDT4: MOVE A,FORK ;GET FORK BEING STARTED
HRRZ A,SLFTAB(A) ;GET ADDRESS OF FORK DATA
MOVE A,DDTSA(A) ;GET DDT'S START ADDRESS FOR THIS FORK
MOVEM A,SA ;REMEMBER START ADDRESS
DDT5: MOVNI B,3 ;CODE FOR PA1050 IF ANY
CALL NOPAT ;PA1050 RUNNING IN FORK?
JRST GOTO2 ;YES
MOVE B,SA ;NO PA1050, GET START ADDRESS
JRST GOTO2 ;JOIN "GOTO" COMMAND: UNMAP PAGE, START FORK.
;7 "<IDDT-style debugger>" and "NO <IDDT-style debugger>" command
;7 F1 is set by "NO <debugger>" command
;7 <debugger> <fork>:
;7 1) splice <debugger> between EXEC and <fork>
;7 <debugger>: (no fork argument)
;7 do the first possible option:
;7 1) continue <debugger> fork, if exists
;7 2) splice <debugger> between EXEC and current unkept fork, if exists
;7 3) start <debugger>
.IDDT:: HRROI A,[ASCIZ/IDDT/] ;7 setup name
HRROI B,[GETSAVE <SYS:IDDT.>] ;7 setup filename
; JRST DEBUGR ;7 join common code
DEBUGR: TRVAR <DBGNMP,DBGFNP,DBGJFN,USRFRK>;7 debugger name ptr, filename ptr,
;7 JFN, user fork
MOVEM A,DBGNMP ;7 store debugger name ptr, and file name ptr
MOVEM B,DBGFNP ;7
TLNE Z,F1 ;7 is it "NO"?
NOISE <over> ;7 yes, make it sound good
MOVEI B,$FRKNM ;7 get a fork name, or CR
CALL FLDSKP ;7
CMERRX <Fork name, fork number, or CR required> ;7
GTFLDT D ;7 get field type
CAIE D,.CMCFM ;7 CR?
JRST DEBUG1 ;7 no
TLNN Z,F1 ;7 is it "NO"?
JRST DEBUG3 ;7 no, handle "<debugger>" with no fork arg
JRST NODBG4 ;7 yes, handle "NO <debugger>" with no fork arg
DEBUG1: CONFIRM ;7 get confirm
TLNE Z,F1 ;7 is it "NO"?
SETOM SVAL0 ;7 yes, don't warn about not direct inferior
CALL FRKNM0 ;7 get fork handle into A
TLNN Z,F1 ;7 is it "NO"?
JRST DEBUG2 ;7 no, handle "<debugger> <fork>"
MOVE C,A ;7 yes, handle "NO <debugger> <fork>"
JRST NODBG1 ;7
;7 "<debugger> <fork>"
DEBUG2: MOVEM A,USRFRK ;7 save user fork
SETO A, ;7 clear mapped page buffer
CALL MAPPF ;7
JRST CJERRE ;7
MOVE B,DBGFNP ;7 get JFN on debugger program file
CALL TRYGTJ ;7
ERROR <Debugger .EXE file not found> ;7
MOVEM A,DBGJFN ;7 save the JFN
MOVEI Q1,ETTYMD ;7 save EXEC's TTY modes
CALL LTTYMD ;7
CALL PIOFF ;7 no CTRL/Cs
MOVE A,DBGJFN ;7 get program
SETOM FORK ;7 (force to create new fork, can't CALL ERESET
CALL $GET0 ;7 since it will probably clobber user fork)
MOVE A,FORK ;7 check entry-vector, we need a length of 3
CALL GETENT ;7
CAIGE B,1000 ;7
CAIGE B,3 ;7
JRST [MOVE A,USRFRK ;7 bad entry-vector, kill debugger
EXCH A,FORK ;7
CALL KEFORK ;7
ERROR <Bad debugger .EXE format>] ;7
MOVE A,FORK ;7 mark debugger fork properly
MOVX B,FK%DBG ;7
IORM B,SLFTAB(A) ;7
MOVE B,USRFRK ;7 splice user fork under debugger
SPLFK ;7
CALL [PUSH P,A ;7 error, save error code
MOVE A,USRFRK ;7 kill debugger fork
EXCH A,FORK ;7
CALL KEFORK ;7
POP P,A ;7
JRST JERR] ;7
MOVEM A,PAGEN+1 ;7 give debugger a handle on user fork, via ACs
MOVE A,FORK ;7
MOVEI B,PAGEN ;7
SFACS ;7
MOVE B,USRFRK ;7 update fork tables
HRLM A,@SLFTAB(B) ;7 user fork's superior is now debugger
HRRM B,@SLFTAB(A) ;7 debugger's inferior is now user fork
MOVX C,FK%UND ;7 mark user fork as under debugger
IORM C,SLFTAB(B) ;7
CALL PION ;7 CTRL/Cs allowed
MOVEM A,RUNFK ;7 running fork is debugger
MOVX B,2 ;7 start at version entry of entry vector!
SFRKV ;7
CALL FTTYMD ;7 set fork TTY modes
TLO Z,RUNF ;7 set to tell what to do on CTRL/C
CALLRET WAITF ;7 wait for debugger to terminate
;7 <debugger> with no fork argument
DEBUG3: CALL FINDBG ;7 is there a debugger fork already?
JRST DEBUG4 ;7 no
MOVEM C,FORK ;7 yes, make it current fork
MOVEM C,RUNFK ;7
CALLRET ..CNT0 ;7 continue it
DEBUG4: MOVX B,FK%KPT ;7 is current fork unkept?
SKIPLE A,FORK ;7
TDNE B,SLFTAB(A) ;7
ABSKP ;7
JRST DEBUG2 ;7 yes
MOVE B,DBGFNP ;7 no, get JFN on debugger program file
CALL TRYGTJ ;7
ERROR <Debugger file not found> ;7
MOVEM A,DBGJFN ;7 save the JFN
MOVEI Q1,ETTYMD ;7 save EXEC's TTY modes
CALL LTTYMD ;7
CALL ERESET ;7 cleanup loose forks
MOVE A,DBGJFN ;7 restore JFN
CALL $GET0 ;7 get program
MOVE A,FORK ;7 mark debugger fork properly
MOVX B,FK%DBG ;7
IORM B,SLFTAB(A) ;7
CALLRET ..STRT ;7 start the debugger
;7 NO <debugger> <fork>:
;7 1) unsplice <fork>
;7 NO <debugger>: (no fork argument)
;7 do first possible option:
;7 1) unsplice current fork, if its spliced with <debugger>
;7 2) find <debugger> and unsplice it
.NO:: HELPX < an IDDT style debugger name, one of the following:> ;7
KEYWD $NO ;7 get specific debugger
0 ;7
JRST CERR ;7
TLO Z,F1 ;7 set "NO" flag
JRST (P3) ;7
$NO: TABLE ;7 table of IDDT-style debuggers
T iddt ;7
TEND ;7
;7 "NO <debugger> <fork>"
NODBG1: MOVE D,SLFTAB(C) ;7 get fork's flags
TXNE D,FK%DBG ;7 is it a debugger with a name?
TXNN D,FK%NAM ;7
JRST NODBG2 ;7 no, get its superior
MOVE A,DBGNMP ;7 yes, is debugger name a subset of fork name?
HRROI B,@.FKNAM(D) ;7
STCMP ;7
SKIPE A ;7
TXNE A,SC%SUB ;7
JRST NODBG3 ;7 yes
NODBG2: HLRZ C,.FKOWN(D) ;7 no, get its superior
CAIE C,.FHSLF ;7 is superior the EXEC?
JUMPG C,NODBG1 ;7 no, check this fork
MOVE A,DBGNMP ;7 yes
ERROR <Not under %1$ debugger> ;7
NODBG3: CALL PIOFF ;7 no CTRL/Cs
MOVEM C,FORK ;7 store debugger fork
HRRZ B,.FKOWN(D) ;7 set user fork's superior to be EXEC
MOVX A,.FHSLF ;7
SPLFK ;7
CALL SCREWUP ;7
MOVE B,A ;7 update fork tables
MOVE A,FORK ;7
MOVX C,.FHSLF ;7
HRLM C,@SLFTAB(B) ;7 user fork's superior is now EXEC
HLLZS @SLFTAB(A) ;7 debugger has no inferior
MOVE C,SLFTAB(B) ;7 fix up user fork's flags
TXZ C,FK%UND ;7 no longer under debugger
TXO C,FK%RUN ;7 probably runnable
MOVEM C,SLFTAB(B) ;7
MOVEM B,FORK ;7 make user fork be current fork
MOVEM B,RUNFK ;7
CALL PION ;7 CTRL/Cs allowed
CALLRET KEFORK ;7 kill debugger
;7 "NO <debugger>" with no fork argument
NODBG4: MOVX A,FK%DBG!FK%UND ;7 is the current fork either the debugger
SKIPLE C,FORK ;7 or the user fork?
TDNN A,SLFTAB(C) ;7
ABSKP ;7
JRST NODBG1 ;7 yes
CALL FINDBG ;7 no, look for debugger fork
ABSKP ;7
JRST NODBG1 ;7 found it
MOVE A,DBGNMP ;7 can't find one
ERROR <No %1$ debugger fork> ;7
;7 Find Debugger Fork Handle
;7
;7 return: +1 error
;7 +2 C/ fork handle
;7 note: uses DBGNMP transient variable
FINDBG: MOVEI A,FRKNMS ;7 look in fork names table
MOVE B,DBGNMP ;7
TBLUK ;7
TXNE B,TL%NOM!TL%AMB ;7 no match, or ambiguous?
RET ;7 yes
HRRZ A,(A) ;7 load the handle into C
LOAD C,FKHAN,(A) ;7
MOVX A,FK%DBG ;7 is the debugger bit set?
TDNN A,SLFTAB(C) ;7
RET ;7 no
RETSKP ;7 yes
;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
RET ;7 style
;7 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
GTFLDT D ;SEE WHAT WE GOT
CAIN D,.CMCFM ;JUST TYPED CR?
JRST FRKNM2 ;YES - GET HIM A FORK
CONFIRM ;7 get confirm before decoding fork, which may
CALLRET FRKNM0 ;7 cause warnings, which also require confirms
;7 CALL FRKNM0 ;CHECK FURTHER ARG
;7 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: 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,FRKDES ;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
ETYPE < %%Specified fork is the EXEC%_> ;7 warning
CALL GOAHED ;7 do it anyway?
RET] ;OK - RETURN
CAIL A,FRKDES+1 ;CHECK VALID RANGE
CAILE A,FRKDES+777
FRKNMX: ERROR <Fork handle must be between 1 and 777>
PUSH P,A ;SAVE IT
RFSTS ;CHECK EXISTENCE
ERJMP CJERRE
TLNE A,77700 ;SEE IF ASSIGNED
ERROR <No such fork>
POP P,A ;RETURN FORK HANDLE
CAIN A,.FHSLF ;DON'T CHECK IF "FORK 0"
RET
SKIPN B,SLFTAB(A) ;KNOW ABOUT THIS FORK?
JRST [ETYPE < %%Unknown fork%_>
RET]
TXNE B,FK%INV ;715 INVOKE'd fork?
JRST [ETYPE < %%PCL invoked fork%_> ;7 warn
CALL GOAHED ;7 do it anyway?
JRST .+1] ;7
SKIPE SVAL0 ;7 if set, don't warn about not direct inferior
RET ;7
HLRZ B,.FKOWN(B) ;GET OWNER HANDLE
ABSKP
OURFRK: HLRZ B,@SLFTAB(A) ;7 test if our fork?
CAIN B,.FHSLF ;7 owned by EXEC?
;7 CAIE B,.FHSLF ;OURS?
RET ;7 yes
ETYPE < %%Fork is not a direct inferior%_> ;7 no
CALL GOAHED ;7 do it anyway?
RET
;MISC FORK COMMANDS
;GIVE A FORK A (NEW) NAME
.NAME:: NOISE <current fork as>
WORDX <Name to call fork by>
CMERRX
CONFIRM
SKIPG A,FORK ;MUST HAVE FORK
ERROR <No current fork>
LDB B,[FIRCHR ATMBUF]
CAIN B,0 ;CHECK FOR NULL NAME
ERROR <No name given>
MOVE Q1,SLFTAB(A) ;POINT TO FORK DATA BLOCK
TXNN Q1,FK%NAM ;7 warn if not named already
JRST [ETYPE < %%Fork currently not named%_> ;7
CALL GOAHED ;7 do it anyway?
JRST .+1] ;7
CALL DELNAM ;DELETE OLD NAME
HRROI B,ATMBUF ;POINT NAME TYPED
CALLRET ADDNAM ;PUT NEW FORK IN TABLE AND RETURN
;KEEP A FORK
.KEEP:: NOISE <fork>
SETOM SVAL0 ;7 don't warn about not direct inferior here
CALL FRKNAM ;GET ITS NAME
HLRZ B,@SLFTAB(A) ;7 not direct inferior?
CAIE B,.FHSLF ;7
ERROR <Cannot keep fork which is not a direct inferior> ;7 yes
;7 MOVX B,FK%KPT ;LIGHT FLAG SO ANNKEP DOESN'T ANNOUNCE ANYTHING
;7 IORM B,SLFTAB(A)
CALLRET ANNKEP ;PUT FORK'S NAME IN TABLE OF KEPT FORKS
;UNKEEP A FORK
.UNKEE::NOISE <fork>
CALL FRKNAM ;GET NAME
MOVX B,FK%KPT
SKIPE CCKEEP ;KEEPING INTERRUPTED FORKS?
TXO B,FK%INT ;YES - LIGHT THIS BIT ALSO
TDNN B,SLFTAB(A) ;FORK INTERRUPTED OR KEPT?
JRST [TYPE < %Fork not kept>
RET]
ANDCAM B,SLFTAB(A) ;CLEAR BIT(S)
HRRZ A,SLFTAB(A) ;GET ADDRESS OF FORK BLOCK
HRRO A,.FKNAM(A) ;GET POINTER TO POSSIBLE NAME
TRNN A,-1 ;IF NO NAME, DON'T TRY TO REMOVE NAME
RET
CALLRET REMKEP ;REMOVE NAME IF IT WAS A KEPT FORK AND RETURN
;FREEZE A FORK
.FREEZ::NOISE <fork>
CALL FRKNAM ;ASK FOR NAME OR NUMBER; GET HANDLE IN AC A
CAIN A,.FHSLF ;GOT OURSELF?
JRST FRKNMX ;YES - THAT'S ILLEGAL
FFORK ;FREEZE IT
RET ;RETURN
;MERGE <FILE> COMMAND.
; GETS A FILE INTO CURRENT FORK WITHOUT RESETTING. PUTS BACK ENTRY VECTOR
; WORD THAT WAS THERE BEFORE COMMAND
.MERGE::NOISE <program>
CALL $GET1 ;INPUT PROGRAM NAME
;SUBROUTINE ENTRY FOR "DDT" COMMAND. PASS JFN IN A.
$MERGE: STKVAR <MERJFN,<MERENT,2>,MERSEC>
MOVEM A,MERJFN ;REMEMBER PROGRAM BEING MERGED
MOVEM B,MERSEC ;REMEMBER SECTION NUMBER
SKIPGE C,FORK ;SKIP IF EXEC HAS INFERIOR FORK
JRST $GET2 ;NO FORK, CREATE ONE, GET PROG, USE ITS ENTRY.
MOVE A,C ;FORK HANDLE TO A
CALL GETENT ;GET ENTRY VECTOR
DMOVEM B,MERENT ;SAVE IT
MOVE A,MERJFN ;TELL $GET2 WHAT PROGRAM TO GET
MOVE B,MERSEC
CALL $GET2 ;GET PROGRAM
MOVE A,FORK ;FORK HANDLE AGAIN
DMOVE B,MERENT ;GET SAVED ENTRY VECTOR
CALLRET SETENT ;SET ENTRY VECTOR AND RETURN
;SUBROUTINE TO INPUT A PROGRAM NAME.
; FIRST PART OF GET, RUN, MERGE.
;
; RETURNS: A/ JFN
; B/ -1 OR SECTION TO USE
$GET1: SETZ A, ;NO DEFAULT FOR DEVICE OR DIRECTORY
GET1S: STKVAR <SGJFN>
CALL CPFN ;INPUT PROGRAM NAME AND ASSIGN JFN
CMERRX ;PRINT COMMAND ERROR IF CAN'T GET NAME
MOVEM A,SGJFN ;REMEMBER JFN
CALL GSWIS ;GET SWITCHES
MOVE B,A ;RETURN SECTION IN B
MOVE A,SGJFN ;RETURN JFN IN A
RET
;GSWIS GETS SWITCHES FOR GET-CLASS COMMANDS.
;
; RETURNS: A/ -1 OR SPECIAL SECTION
GSWIS: TRVAR <USESEC>
SETOM USESEC ;SAY NO SPECIAL SECTION TO USE
GET3: MOVEI B,[FLDDB. .CMSWI,,GETSWI,,,[
FLDDB. .CMCFM]]
CALL FLDSKP ;SEE WHAT'S BEING TYPED
CMERRX
GTFLDT D
CAIN D,.CMSWI ;SWITCH?
JRST [CALL GETKEY ;YES, SEE WHICH ONE
CALL (P3) ;EXECUTE THE SWITCH
JRST GET3] ;GET MORE INPUT
MOVE A,USESEC ;RETURN -1 OR SECTION IN A
RET
;TABLE OF SWITCHES FOR GET-CLASS COMMANDS
GETSWI: TABLE
T use-section:,,GUSE
TEND
GUSE: OCTX <Section to get program into>
CMERRX <Invalid section number>
MOVEM B,USESEC ;REMEMBER SPECIFIED SECTION
RET
;ERUN COMMAND - RUN A PROGRAM AS AN EPHEMERON
.ERUN:: NOISE <program>
MOVEI A,[ASCIZ/SYS:/] ;DEFAULT TO SYS:
CALL CPFN ;INPUT PROGRAM NAME AND GET JFN
JRST [MOVE A,ERCOD ;PRINT ERROR
JRST CJERR]
CONFIRM
CALLRET REPH ;START IT UP
;R COMMAND. EQUIVALENT TO RUN <SUBSYS>...
.R:: NOISE <program>
MOVEI A,[ASCIZ/SYS:/]
CALL GET1S ;READ PROGRAM NAME AND SWITCHES
PUSH P,[..STRT] ;SET UP TO START AFTER GET
JRST GET1 ;JOIN GET
;RUN <PROGRAM> COMMAND = GET + START
.RUN:: PUSH P,[..STRT] ;SET RETURN TO JOIN "START" COMMAND,
;FALL INTO "GET".
;GET <FILE> COMMAND.
; RESETS THEN CREATES ONE FORK AND GETS PROGRAM INTO IT.
; CODED IN SUBROUTINES SO CODE CAN BE SHARED WITH "MERGE".
.GET:: NOISE <program>
CALL $GET1 ;INPUT PROGRAM NAME
;R COMMAND JOINS HERE AFTER CALLING CPFN AND SETTING
; RETURN TO JOIN START COMMAND (..STRT).
GET1: PUSH P,A ;SAVE JFN
PUSH P,B ; AND SECTION
CALL ERESET ;CLOSE FILES, KILL ALL INFERIOR FORKS.
POP P,B ;RESTORE SECTION
POP P,A ; AND JFN
CALLRET $GET2 ;GET THE PROGRAM AND RETURN
;GET...
;SUBROUTINE TO GET A PROGRAM INTO CURRENT FORK, FOR GET, RUN, AND MERGE.
;
; ACCEPTS: A/ JFN
; B/ -1 OR SPECIAL SECTION
$GET0:: SETO B, ;SPECIAL ENTRY TO FORCE NO SPECIAL SECTION
$GET2:: STKVAR <GETJFN,GETSEC,<GBLK,1+.GBASE>>
;IF THERE IS NO INFERIOR FORK, CREATE ONE.
MOVEM A,GETJFN ;REMEMBER WHICH FILE TO GET
MOVEM B,GETSEC
DELETE,<CALL PNTMES> ;ELIMINATE ONE BAD IDEA
;ALWAYS MAKE SURE SYSTEM MESSAGES HAVE BEEN
; PRINTED BEFORE ALLOWING ANY PROGRAMS TO BE
; RUN. THIS PREVENTS PROBLEM OF SYSTEMS THAT
; START UP SPECIAL PROGRAMS FROM NEVER SEEING
; SYSTEM MESSAGES, BECAUSE LOGIN.CMD OR
; COMAND.CMD RUNS PROGRAM.
SKIPL FORK
JRST GET2B ;HAPPENS FOR "MERGE"
CALL ECFORK ;CREATE A FORK
TLO Z,F1 ;7 remember the fork is new
;DETERMINE SUBSYSTEM NAME BUT DON'T SETNM AT THIS POINT
MOVE B,GETJFN ;JFN
CALL SFKNAM ;SET FORK NAME
ABSKP ;7 skip over clearing new flag
;PUT THE PROGRAM INTO THE FORK
;FOR USE AT "WAITF"+2 BY "START", ETC.
GET2B: TLZ Z,F1 ;7 this fork is not new
HRR A,GETJFN
HRL A,FORK
SKIPGE B,GETSEC ;ANY SPECIAL SECTION?
JRST GET2BE ;NO, USE OLD FORMAT GET
TXO A,GT%ARG ;YES, TELL GET THERE'S AN ARG BLOCK ADDRESS
; IN B
MOVEM B,.GBASE+GBLK ;STORE SECTION TO USE
MOVX B,GT%BAS ;TELL GET TO USE THE SPECIFIED SECTION
MOVEM B,.GFLAG+GBLK
XMOVEI B,GBLK ;TELL GET WHERE ARG BLOCK IS
GET2BE: CALL DOGET ;DO THE GET JSYS
JRST GETILI ;FAILED
MOVE A,FORK ;GET FORK HANDLE
HRRZ C,SLFTAB(A) ;GET ADDRESS OF FORK DATA
SKIPL CODSEC(C) ;IS THERE ALREADY A SECTION SET UP?
RET ;YES - DONE
SKIPL B,GETSEC ;NO - WANT A SPECIAL SECTION?
JRST GET2BF ;YES - SAVE THAT SECTION NUMBER
CALL GETENT ;NO - USE ENTRY VECTOR SECTION AS CODE SECTION
HLRZ B,C ;GET SECTION OF ENTRY VECTOR
HRRZ C,SLFTAB(A)
GET2BF: MOVEM B,CODSEC(C) ;REMEMBER WHICH SECTION CODE IS IN
RET ;DONE
;ILLEG INST TRAP DURING GET JSYS. TYPE EXEC ERROR MESSAGES FOR CERTAIN ERRORS
GETILI::CALL %GETER
MOVE A,FORK ;7 kill fork, if just created
TLZE Z,F1 ;7
CALL KEFORK ;7
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
MOVX A,.FKSZE ;SIZE OF FRKTBL ENTRY
CALL GTBUFX ;GET BLOCK FROM PERMANENT FREE SPACE
MOVE Q1,A ;SAVE ADDRESS IN Q1
MOVX A,CR%CAP
CFORK ;CREATE A FORK (SAME CAPS)
JRST [PUSH P,A ;SAVE ERROR CODE
MOVX A,.FKSZE
MOVE B,Q1 ;BLOCK ADDRS
CALL RETBUF ;RETURN BLOCK
POP P,A ;RESTORE CODE
JRST JERR]
MOVEM A,FORK ;SAVE AS CURRENT FORK
HRRZM Q1,SLFTAB(A) ;SAVE POINTER TO FORK DATA
SETOM CODSEC(Q1) ;NO SPECIAL SECTION NUMBER YET
MOVE A,FORK ;GET FORK HANDLE AGAIN
FFORK ;TFORK REQUIRES IT TO BE FROZEN (STUPID RULE)
CALL MRKTRP ;NEW FORK REQUIRES ANOTHER TFORK
CALL PION ;ALLOW ^C NOW THAT BLOCKS ARE MADE AND SET UP
MOVE A,FORK ;GET FORK HANDLE AGAIN
SETO B,
SETZ C,
SKIPE PAXLFL ;LEGAL FOR COMPAT PKG?
SCVEC ;NOPE - CLEAR IT
FFORK ;LEAVE FORK FROZEN
;7 decide what capabilities to give to inferior
MOVE A,FORK ;7 get current fork capabilities
RPCAP ;7
AND B,CAPMSK ;7 screen out any unwanted caps
AND C,CAPMSK ;7
SKIPN BATCHF ;7 don't allow ^C under batch
SKIPE CCFLAG ;7 or if user wants not to
JRST [TXZ B,SC%CTC ;7
TXZ C,SC%CTC ;7
JRST .+1] ;7
SKIPE PRVENF ;7 enabled? no inferior caps enabled if not
MOVE C,B ;7 yes, enable inferior's capabilities
EPCAP ;7
;7 old code here
DELETE,<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
MOVX 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
MOVX 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.
;
; ACCEPTS: A/ THE JFN
; RETURNS: +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
MOVX C,FLD(.JSAOF,JS%NAM) ;REQUEST NAME
JFNS ;GET NAME FIELD FROM JFN
ERCAL JERRE
HRROI A,SSBUF
CALL GETSIX ;GET SIXBIT OF NAME
NOP ;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
MOVX C,FLD(.JSAOF,JS%DIR) ;REQUEST DIRECTORY NAME
JFNS
ERCAL JERRE
HRROI A,SSBUF
MOVE B,[TXTPTR <SUBSYS>]
STCMP ;COMPARE NAMES
JUMPE A,SUBNX ;JUMP IF NAMES THE SAME
JRST SUBNP
;USE (PRIV) FOR SYSTEM NAME
SUBNP: MOVX 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: B/ ADDRESS TO START AT (UNLESS DSFF IS ON)
; RETURNS: +1 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
ERSKP ;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
ERSKP ;FAILED
RET ;DONE
CALL DGETER ;FAILED, SEE WHY
CAIE A,ILINS2 ;OLD MONITOR?
CALL CJERRE ;NO, OTHER ERROR SO TELL USER
MOVE A,SFH ;RESTORE FORK HANDLE
MOVE B,SLEN
MOVE C,SADR ;DON'T ASSUME DGETER PRESERVES TEMPS
TLNE C,-1 ;WILL ADDRESS FIT IN RIGHT HALF?
ERROR <Entry vectory addresses larger than 18 bits are illegal>
HRL B,B ;PUT LENGTH IN LH
HRR B,C ;AND ADDRESS IN RH OF B
SEVEC ;DO IT THE OLD WAY
ERCAL CJERRE ;TELL USER OF FAILURE
RET
;DSFORK STARTS FORK UNLESS PA1050 ALREADY DID
;
; ACCEPTS: A/ HANDLE
; B/ DSFF + PC
DSFORK: TXZE B,DSFF ;DON'T START FORK IF NOPAT DID
RET
LSHC B,-^D36 ;CLEAR FLAGS AND GET PC INTO C
XSFRK% ;START THE FORK
ERJMP DSFRK1 ;FAILED
RET ;O.K.
DSFRK1: CALL DGETER ;SEE WHY THE START FAILED
CAIE A,ILINS2 ;OLD MONITOR?
CALL JERR ;NO, STRANGE ERROR
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
SKIPGE FORK
ERROR <No program>
NOISE <on file>
CALL SAVNMX
MOVEI Q2,-1+SAVSTK ;FORM STACK POINTER TO ARG STACK
HRLI Q2,-CSTKLN ;USE COUNT TO CATCH TOO MANY ARGUMENTS
SAVE1: NOISE <words from>
DEFX <20> ;BEGINNING OF BLOCK DEFAULTS TO 20
ADDRX <First word of memory block to be saved, in octal, or carriage
return>
ERROR <Invalid word>
PUSH Q2,B ;BUILD TABLE OF "SAVE" ARGUMENTS IN PUSHDOWN
NOISE <to>
DEFX <777777> ;THIS IS DEFAULT END OF BLOCK
ADDRX <Last word of memory block to be saved, octal>
ERROR <Invalid word>
SUB B,(Q2)
JUMPL B,[ERROR <Second address is smaller than first>]
ADDI B,1
TLNE B,1
JRST [MOVX B,1B18 ;FOR 0 TO 777777 LENGTH IS 1000000,
HRLM B,(Q2) ;...WHICH IS MORE THAN 18 BITS,
PUSH Q2,[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>
ABSKP ;NOT COMMA
JRST SAVE1 ;USER TYPED COMMA, INPUT ANOTHER PAIR
MOVE Q3,[SAVE] ;GET APPROPRIATE JSYS
DOSAV: CONFIRM
PUSH Q2,[0] ;TERMINATE TABLE
MOVE A,FORK
MOVE B,SAVJFN
CALL SFKNAM ;SET UP FORK NAME
MOVE A,CSBUFP ;7 restore full file name (SFKNAM smashes it)
MOVE B,SAVJFN ;7
SETZ C, ;7
JFNS ;7
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(10,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>
ABSKP ;NO COMMA TYPED
JRST SSAV1 ;COMMA TYPED, GO GET NEXT BLOCK
MOVE Q3,[SSAVE] ;SET UP CORRECT JSYS
JRST DOSAV
ILISSA: CALL %GETER
MOVE A,ERCOD
MOVE C,SAVJFN
CALLRET OPNERR ;ANALYZE ERROR
SAVNAM: ;PCL No noise
SKIPLE C,FORK ;ACTIVE FORK?
SKIPN C,SLFTAB(C) ;YES - FRKTBL ENTRY
JRST SAVNM2
SKIPE C,.FKPTM+TTWPNM(C) ;GET NAME IF ANY
CAMN C,[SIXBIT/(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()]
SETZ B, ;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
SETZ C, ;GET STANDARD FORMAT STRING
JFNS
MOVE A,CSBUFP
CALL BUFFS ;ISOLATE THE NAME
MOVEM A,SAVFIL ;REMEMBER FILENAME
RET
;START - DECODE AND CHECK SUBROUTINE ALSO USED BY REDIRECT/DETACH
$START::SKIPGE A,FORK ;HANDLE OF INFERIOR FORK, OR -1
ERROR <No program>
CALL GETENT ;GET ENTRY VECTOR
CAIGE B,1
ERROR <No START address>
RET
;START COMMAND DISPATCHES HERE
.START::NOISE <program>
SETZM STAYF
COMMAX <Comma to enter subcommands,
Octal start address
or Confirm with carriage return>
JRST .STRT0 ;NO COMMA
CONSTG ;ALLOCATE STORAGE
MOVE A,FORK ;ASSUME CURRENT FORK UNLESS CHANGED
MOVEM A,UFORK
CALL .CONT3 ;HANDLE SUB-COMMANDS (SET MODE)
JRST .STRT1 ;COMMON CODE
.STRT0: CRRX <Octal start address
or Confirm with carriage return>
ABSKP ;NOT JUST CR TYPED
JRST .STRT1 ;JUST CR, START AT REAL START ADDRESS
ADDRX <Octal start address>
ERROR <Invalid address>
MOVE A,B ;GET START ADDRESS INTO A
CONFIRM
JRST .GOTO
.STRT1: CALL $START ;GET ADDRS
JRST STR1
;"RUN" JOINS HERE, REDIRECT/DETACH...(AND) START JOINS HERE
..STRT::SETZM STAYF
STR1: SETO B, ;START CODE FOR PA1050
CALL NOPAT ;SEE IF PA1050 THERE
JRST ..STCR ;YES
SETZ B, ;ENTRY VECTOR INDEX 0 FOR START
;START FORK WHOSE HANDLE IS IN "FORK" USING ENTRY VECTOR INDEX IN B.
; "REENTER" JOINS HERE.
..STCR::CALL SETGO ;SET UP FOR PROGRAM RUNNING
TXNN B,DSFF ;FORK ALREADY STARTED?
CAIL B,1000 ;NO, PROPER ENTRY VECTOR DISPATCH?
JRST [CALL DSFORK ;START FORK UNLESS PA1050 DID
JRST WAITR]
SFRKV ;START FORK USING ENTRY VECTOR (USES A,B)
ERJMP CJERRE
;GIVE LAST COMMAND BUFFER TO MONITOR FOR USER RSCAN
WAITR: CALL CRSCAN
;START AND REENTER... CONTINUE AND GOTO JOIN HERE.
; ANY OF THE ABOVE WITH REDIRECT OR DETACH ALSO GET HERE.
; WAIT FOR FORK TO TERMINATE, AFTER DETACHING TERMINAL IF "DTACHF" ON.
;NOW WAIT FOR FORK TO TERMINATE
WAITF:: CALL WAITA ;WAIT FOR FORK TO TERMINATE
JRST (A) ;DISPATCH TO NEXT ROUTINE TO BE RUN
;ROUTINE TO WAIT FOR A FORK TO TERMINATE
;
; RETURNS: +1 A/ ADDRESS OF NEXT ROUTINE TO DISPATCH TO
WAITA:: ;PCL
;CHECK AND DETACH TERMINAL
TLNE Z,DTACHF ;"DETACH" COMMAND?
DTACH ;YES, DETACH CONTROLLING TERMINAL.
SKIPN STAYF ;DON'T SET PROGRAM MODE IF STAYING AT COMMAND
; LEVEL
CALL SETPRG ;SAY PROGRAM MODE
TLO Z,RUNF ;MAKE ^C KNOW THAT FORK NEEDS TO BE FROZEN
MOVE A,RUNFK ;FORK WE ARE REALLY RUNNING
RFORK ;RESUME IT
UTFRK ;THIS IS NECESSARY IF THE FORK WAS JSYS-TRAPPED
ERNOP ;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 ;715 do not wait if have just received PSI
WFORKX:: WFORK ;PCL WAIT. WFORKX: M-U-S-T BE ON WFORK
FFORK ;FREEZE IT IMMEDIATELY
NOWAIT: SETZM PCWAIT ;715 see 715 above
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
TMNN FK%INV,SLFTAB(A) ;715 if not controlled program
;715 SKIPN PCPRGR ;PCL Not if controlled program
CALL LTTYMD ;..
;ANALYZE REASON FOR TERMINATION
MOVEI B,.RFSFL+1 ;SET UP FOR LONG FORMAT RFSTS
MOVEM B,LRFSTS+.RFCNT
HRLI A,(RF%LNG) ;ASK FOR LONG FORMAT
MOVEI B,LRFSTS
RFSTS ;READ FORK STATUS (HANDLE IN A)
MOVE B,LRFSTS+.RFPSW ;GET STATUS WORD
TLNN B,77700 ;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
ABSKP ;STANDARD HALT OR JSYS TRAP (ALREADY REPORTED)
JRST FKTRM1 ;ERROR, GO ANALYZE.
MOVE A,FORK ;GET FORK HANDLE
TMNE FK%INV,SLFTAB(A) ;715 Controlled program?
;715 SKIPE PCPRGR ;PCL Controlled program?
RET ;PCL Yes, leave it at that
HRLI A,.PRARD ;SET TO READ
MOVEI B,PRBUF ;USE THIS
MOVX C,PRLEN ;A GOOD MAX
PRARG ;READ PROCESS ARGS
ERJMP FRKTRN ;IGNORE IF FAILURE
;7 read special function codes sent by fork
JUMPE C,FRKTRN ;7 zero length arg block
HLRZ A,PRBUF ;7 check function code
CAIN A,.PRCCL ;7 looks like asking for last CCL command?
JRST FRKCCL ;7 yes
HRRZ B,PRBUF ;7 is arg blk address zero?
JUMPN B,FRKEXI ;7 no, not special function
CAIE A,.PRKEP ;7 keep fork and halt it?
JRST FRKKIL ;7 no, try something else
MOVE A,FORK ;7 yes, is there a current fork?
JUMPLE A,FRKEXI ;7 no
MOVX B,FK%KPT ;7 yes, mark keep bit
IORM B,SLFTAB(A) ;7
MOVE B,SLFTAB(A) ;7 does fork have a name?
TXNE B,FK%NAM ;7
CALL ANNKEP ;7 yes, put fork in kept fork names table
JRST FRKEXI ;7 cleanup
FRKKIL: CAIE A,.PRKIL ;7 kill the fork?
JRST FRKBKG ;7 no, try something else
MOVE A,FORK ;7 yes, kill it
CALL KEFORK ;7
CALL NXTFRK ;7 select new current fork
JRST FRKTRN ;7 go back to parser
FRKBKG: CAIE A,.PRBKG ;7 continue fork in background?
JRST FRKEXI ;7 no, bad function code, cleanup
CALL PRCLR ;7 clear PRARG arguments
MOVE A,FORK ;7 setup for continue background signal
MOVE D,SLFTAB(A) ;7
MOVSI Q1,.SIGIO ;7
SETOM STAYF ;7
CALL .CONT6 ;7
CALL $CONTI ;7
MOVE A,RUNFK ;7 continue fork
TXO A,SF%CON ;7
SFORK ;7
ERCAL CJERRE ;7
CALL UTTYMD ;7 set the terminal mode
MOVE A,RUNFK ;7
RFORK ;7 resume
UTFRK ;7 make the JSYS traps work
ERNOP ;7
MOVX B,FK%RUN ;7 mark as running
SKIPE SLFTAB(A) ;7
IORM B,SLFTAB(A) ;7
JRST FRKTRN ;7
FRKCCL: ;7 add local label
HLRZ A,1+PRBUF ;CHECK HEADER
MOVE B,PRBUF
CAIN B,1 ;# OF ARGS
CAIE A,(4B2!17B12) ;CHECK TYPE
JRST FRKEXI ;7 garbage data, go cleanup
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
FRKEXI: CALL PRCLR ;7 clean up argument block
FRKTRN: MOVEI A,CMDIN2 ;GO TO START OF PARSER
SETZM STAYF ;7 no longer STAYing
RET
PRCLR: HRRZ A,FORK ;SET TO CLEAR ARGS
HRLI A,.PRAST
SETZB B,C
PRARG
RET
;HERE IF FORK TERMINATES INVOLUNTARILY AFTER START OR REENTER. PRINT REASON.
; FORK HANDLE IS IN A, STATUS IN B.
FKTRM1: LDB C,[POINTR .RFPSW+LRFSTS,RF%STS] ;GET REASON MINUS FROZEN BIT
CAIN C,.RFABK ;ADDRESS BREAK?
JRST [SOSGE ABKCNT ;DECREMENT REPEAT COUNTER
JRST FKTRM2 ;COUNTER EXPIRED, REPORT IT
MOVEI A,WAITF ;NOT EXPIRED, KEEP RUNNING FORK
RET] ;DISPATCH VIA WAITF, CLEANING STACK
CAIN C,.RFTRP ;JSYS/UUO TRAP???
JRST [MOVE B,LRFSTS+.RFPPC ;LOAD PC FOR USE WITH %Y
ERROR <JSYS or UUO trap at %2Y>]
TMNE FK%INV,SLFTAB(A) ;715 controlled program?
JRST [CAIN C,.RFIO ;715 in I/O wait?
RET ;715 yes, let PCL handle it
CAIN C,.RFWAT ;715 waiting for inferior?
RET ;715 probably inferior doing I/O to PTY/PDS
CAIN C,.RFRUN ;715 runnable?
RET ;715 probably inferior doing I/O to PTY/PDS
CAIN C,.RFSLP ;715 dismissed?
RET ;715 probably inferior doing I/O to PTY/PDS
JRST .+1] ;715 something else, so invoked fork must have
;715 died somehow
;715 CAIN C,.RFIO ;PCL Waiting for I/O?
;715 SKIPN PCPRGR ;PCL Is it a controlled program?
;715 ABSKP ;PCL No
;715 RET ;PCL Yes, the usual case
CAIE C,.RFFPT ;FORCED TERMINATION (UNENABLED ERROR PSI)
ERROR <Unusual fork termination status %2O>
LOAD C,RF%SIC,.RFPSW+LRFSTS ;(SIC) GET SOFTWARE CHANNEL (TYPE OF ERROR)
CAIG C,^D35 ;CHECK AGAINST TABLE LIMITS
CAIGE C,0 ;..
ERROR <Illegal PSI channel %3Q on forced termination>
MOVE A,FORK ;LOAD FORK HANDLE FOR POSSIBLE %X
MOVE B,LRFSTS+.RFPPC ;LOAD PC FOR POSSIBLE %Y BELOW
;MESSAGE TABLE ADDRESSED BY WHY IS ALSO USED BY INFORMATION PROGRAM.
; EXPECTS A TO CONTAIN FORK HANDLE FOR %X,
; B TO CONTAIN FULL WORD PC FOR POSSIBLE %Y, AND
; C TO CONTAIN THE CHANNEL FOR POSSIBLE %Q.
WHY:: XCT .+1(C) ;ERROR MESSAGE FROM TABLE FOLLOWING
ERROR <Channel %3Q interrupt at %2Y> ;CHAN 0 These happen if program
ERROR <Channel %3Q interrupt at %2Y> ;CHAN 1 activates channel but
ERROR <Channel %3Q interrupt at %2Y> ;CHAN 2 does not EIR or SIR or
ERROR <Channel %3Q interrupt at %2Y> ;CHAN 3 table word for channel
ERROR <Channel %3Q interrupt at %2Y> ;CHAN 4
ERROR <Channel %3Q interrupt at %2Y> ;CHAN 5
ERROR <Overflow at %2Y> ;CHAN 6
ERROR <Floating overflow at %2Y> ;CHAN 7
ERROR <Channel %3Q interrupt at %2Y> ;CHAN 8
ERROR <Pushdown overflow at %2Y> ;CHAN 9
ERROR <End-of-file at %2Y> ;CHAN 10
ERROR <IO data error at %2Y> ;CHAN 11
ERROR <Quota exceeded at %2Y> ;CHAN 12
ERROR <File error 4 interrupt at %2Y> ;CHAN 13 FILE CONDITION 4
ERROR <Channel %3Q interrupt at %2Y> ;CHAN 14 TIME OF DAY.
ERROR <Illegal instruction %1X> ;CHAN 15 PRINTS PC, 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
MOVX 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,FRKDES(A) ;GET FORK NUMBER IF NO NAME AND MAKE STRING
MOVX C,FLD(10,NO%RDX) ;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
SETZ C, ;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?
ABSKP ;NOT OPENF OR IS OPENF AND WE'RE TRAPPING IT
JRST NOTJ ;THIS IS OPENF BUT WE'RE NOT TRAPPING IT AS A
; JSYS
MOVEI B,JSBDEF ;GET ADDRESS OF BIT MASK
CALL SKPON ;SKIP IF THIS BIT IS ON IN THE MASK
JRST NOTJ ;NO
MOVE A,JNAME ;YES, GET POINTER TO NAME OF FORK
MOVE B,RFPPC ;GET PC
SOJ B, ;SHOW LOCATION OF ACTUAL JSYS (OR XCT!)
LOAD C,YFLD,JINSTR ;GET JSYS NUMBER
HRRO C,JTAB(C) ;GET POINTER TO NAME OF JSYS
ETYPE <%@[%1M trap %2Y/ %3M AC's 1-4: >
MOVSI Q1,-4 ;PREPARE TO LOOP FOR 4 AC'S
NO0: MOVEI A,1(Q1) ;GET AC TO READ CONTENTS OF
CAIE A,1 ;SEPARATOR BETWEEN VALUES BUT NOT BEFORE FIRST
PRINT "\"
CALL RANDOM
JRST [TYPE <?> ;TYPE "?" IF CAN'T READ VALUE
JRST NO1]
ETYPE <%1O>
NO1: AOBJN Q1,NO0 ;LOOP FOR REST
ETYPE <]%_>
NOTJ: MOVE A,JNAME ;GET POINTER TO NAME
CALL STREM ;RETURN FREE SPACE SINCE WE MAY COME THROUGH
; HERE MANY TIMES BEFORE NEXT EXEC COMMAND!
MOVE A,JHAN ;GET FORK HANDLE
CALL FOWNER ;GET OWNER OF FORK. NOTE THAT IT IS NECESSARY
; TO FREEZE THE OWNER RATHER THAN THE FORK
; ITSELF, BECAUSE IF AN INFERIOR FORK BEING
; USED BY SOME PROGRAM IS THE ONE THAT
; TRAPPED AND WE ONLY FREEZE IT, IT'S
; SUPERIOR WILL PROBABLY HANG FOREVER, SINCE
; THE MONITOR DOESN'T ALLOW INFERIOR FORKS TO
; BE THAWED WHILE THEIR SUPERIORS ARE FROZEN
SKIPE TSTOPF
FFORK ;IF WE'RE SUPPOSED TO STOP, FREEZE THE OWNER
SKIPE TSTOPF ;DON'T WAKE UP WFORK IF WE'RE NOT STOPPING
CALL FRZCHK ;WORRY ABOUT MONITOR BUG: WFORK WON'T NOTICE
; FORK!
MOVE A,JHAN ;GET FORK HANDLE
UTFRK ;UNTRAP FORK REGARDLESS OF WHETHER WE'RE
; STOPPING
ERJMP [ETYPE <%% Couldn't release fork from trap - %?%%_>
JRST .+1] ;(EXECUTE-ONLY IS ONE REASON)
MOVE A,REALF ;FIX FORK CELL
MOVEM A,FORK
CALLRET PION ;ALLOW ^C AGAIN
;HERE ON ADDRESS BREAK
FKTRM2: SKIPG A,FORK ;GET FORK HANDLE
JRST [TYPE <No program> ;UNLESS THERE IS NONE
JRST CMDIN2]
HRLI A,.ABRED ;FUNCTION TO READ ADDR BREAK STUFF
ADBRK ;GET ADDR BREAK INFO
MOVE A,LRFSTS+.RFPPC ;GET USER'S PC IN CASE IT WAS A JSYS
ETYPE <%_%%%Address break at location %2Y from user PC %1Y%%_>
JRST FRKTRN ;GO TO MAIN SCANNER LOOP, CLEANING STACK
;HERE ON INFERIOR FORK TERMINATION INTERRUPT
INFTRM::CALL SAVACS ;PRESERVE AC'S
CALL INFTR0 ;ANALYZE FORK STATUS
CALL FRZCHK ;CHECK ON FROZENNESS
CALL RESACS ;RESTORE AC'S
DEBRK ;DISMISS INTERRUPT
;FRZCHK SEES IF THE CURRENT FORK IS NOW FROZEN AND IF THE EXEC WAS WFORKING. IF
; SO, FRZCHK CAUSES THE CURRENT INTERRUPT LEVEL TO DISMISS TO THE INSTRUCTION
; AFTER THE WFORK, WHICH DUE TO MONITOR BUGS WOULDN'T NECESSARILY EVER
; RETURN!
FRZCHK: MOVE A,RUNFK ;GET CURRENT FORK
RFSTS ;GET ITS STATUS
ERJMP INF1 ;IF FAILS, IGNORE
TXNN A,RF%FRZ ;TURN OFF AND TEST FOR FROZENNESS
RET ;NOT FROZEN, SO WFORK WILL FALL THROUGH
; NATURALLY
;NOTE: WITHOUT THE ABOVE FROZENNESS TEST, THE
; EXEC WILL BE FOOLED INTO THINKING WFORK
; SHOULD BE FORCED TO DROP THROUGH IN THE
; EVENT OF "FORK 1" TERMINATING WHILE CURRENT
; FORK IS "FORK 2".
INF1: CALL GETLPC ;GET ADDRESS HOLDING INTERRUPT PC
RET ;NOTHING TO DO IF NO INTERRUPT IN PROGRESS
HRRZ B,@A ;GET PC OF INTERRUPTED INSTR+1
CAIE B,WFORKX
CAIN B,WFORKX+1 ;SEE IF WAITING FOR PROGRAM TO STOP
TLO B,1000 ;LIGHT USERMODE BIT IN PC
IORM B,@A ;SO WFORK DROPS OUT
RET
;SUBROUTINE TO ANALYZE A TERMINATED INFERIOR FORK'S STATUS AND TELL THE USER
; WHAT HAPPENED TO IT
INFTR0: STKVAR <<TRFSTS,.RFSFL+1>,SRFPC>
MOVSI Q1,-NFRKS ;LOOK AT ALL FORKS
INFTR1: SKIPE Q2,FRKTAB(Q1) ;EXISTANT FORK?
TXNN Q2,FK%BKG ;BACKGROUND FORK?
JRST INFTR3 ;NO - KEEP LOOKING
MOVEI A,.FHSLF(Q1) ;FORM HANDLE
MOVX B,.RFSFL+1 ;LENGTH OF LONG RFSTS BLOCK
MOVEM B,.RFCNT+TRFSTS
MOVEI B,TRFSTS ;POINT TO TEMP BLOCK
TXO A,RF%LNG
RFSTS ;READ ITS STATUS
LDB C,[POINTR <.RFPSW+TRFSTS>,RF%STS] ;GET CODE
CAIN C,.RFHLT ;HALTED?
JRST INFTR2 ;YES - INFORM USER
CAIN C,.RFTTY ;WANTS TTY?
JRST [TXOE Q2,FK%TTY ;BLOCKED FOR TTY?
JRST INFTR3 ;BEEN HERE BEFORE
HRROI Q3,[ASCIZ/wants the TTY/]
JRST INFTR4] ;INFORM USER FIRST TIME THROUGH
CAIN C,.RFABK ;ADDRESS BREAK
JRST [HRROI Q3,[ASCIZ/Address break/]
JRST INFT2C]
CAIN C,.RFTRP ;MAYBE JSYS TRAP
JRST [HRROI Q3,[ASCIZ"JSYS/UUO trap at %2Y"]
JRST INFT2C]
CAIE C,.RFFPT ;FORCED TERMINATION?
JRST INFTR3 ;NO - GO ON
HRRZ C,.RFPSW+TRFSTS ;PSI CHL THAT CAUSED TERMINATION
CAIG C,^D35 ;CHECK VALID CHL
CAIGE C,0
JRST [HRROI Q3,[ASCIZ/Illegal PSI channel %3Q/]
JRST INFT2C]
HRRO Q3,WHY+1(C) ;SOFTWARE CHL REASON
JRST INFT2C
INFTR2: HRROI Q3,[ASCIZ/halted at %A/]
MIC,< MOVEI B,FRKDES(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
MOVX A,.FHSLF ;GET PRIMARY I/O FOR SELF
GPJFN
MOVE D,B ;SAVE IN D
MOVEI A,FRKDES(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
NOP
HLL B,D ;RESET FROM OURS
PUSH P,B ;7 reset process TIW with default mask
MOVEI A,FRKDES(Q1) ;7
RTIW ;7
MOVE B,.FKPTM+TTWPTI(Q2) ;7
STIW ;7
POP P,B ;7
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
NOP
HRR B,D ;RESET FROM OURS
INFT2B: MOVEI A,FRKDES(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,[TXTPTR <Fork %5P>]
HRRO Q2,.FKNAM(Q2) ;POINT TO NAME STRING
MOVEI A,FRKDES(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
NOP ;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,(<RF%FRZ!FLD(.RFHLT,RF%STS)>) ;HALT OR FORCE TERM?
CAIN A,(<RF%FRZ!FLD(.RFFPT,RF%STS)>)
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,(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
MOVX B,1B0 ;COMPUTE PROPER BIT
LSH B,(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
ETYPE <%_ %RSCAN failure. Rescanned command truncated, will try to
go on.%_>
POP P,A
RET
;ROUTINES TO HANDLE EPHEMERALS
;
; ACCEPTS: A/ JFN
REPH:: PUSH P,[CMDIN2] ;RETURN HERE
STEPH:: SETZ B, ;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)
NOP ;115 Shouldn't fail
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
ERNOP
CALL PION ;RE-ENABLE ^C
MOVEI A,GETILI ;WHERE TO GO ON "GET" ERROR
MOVEM A,ILIDSP
HRRZ A,PJFN ;GET JFN OF PROGRAM NAME
HRL A,EFORK ;FORK HANDLE
GET
SETZM ILIDSP ;CLEAR ERROR ADDRS
MOVE A,EFORK
CALL CRSCAN ;LOAD RE-SCAN BUFFER IF NECESSARY
CALL GETENT ;7 check validity of entry vector
CAIL B,1000 ;7 too big
CAIN B,(JRST) ;7 TOPS-10 style?
CAIN B,0 ;7 too small
ERROR <Bad .EXE format> ;7 bad entry vector
MOVE B,EVOFF ;RECOVER E-V OFFSET
ADD B,C ;7 kludge to use SFORK, SFRKV bombs on EV
HRRZ B,B ;7 positions greater than 2
SFORK ;7
;7 SFRKV ;START FORK
ERJMP CJERRE ;7 error, say something
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,[FLD(.RFHLT,RF%STS)] ;HALTED?
JRST [MOVE A,EFORK ;YES - JUST KILL IT OFF
KFORK
SETOM EFORK ;NO MORE EPHEMERON
CALLRET PION] ;EXIT (CMDIN2)
TLNE A,77700 ;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
CAIL B,0 ;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: MOVX 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 [SETZ C, ;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,^D10
ADD C,DIGIT
MOVEM C,DECVAL
JRST AV1 ;LOOP FOR MORE OF NAME
AV2: LDB D,B ;GET LAST CHARACTER OF STRING
SETZ C,
IDPB C,B ;PUT NULL AFTER SYMBOL NAME
SOSG ECNT ;MORE THAN A SINGLE E?
SOSLE DPCNT ;MORE THAN A SINGLE DECIMAL POINT?
SETZM NUMFLG ;TWO OR MORE E'S OR TWO OR MORE DP'S - NOT A
; NUMBER!
SKIPN NUMFLG ;IS IT A NUMBER?
JRST AV3 ;NO
CAIE D,"E"
CAIN D,"."
SETZM FLTFLG ;FLOATING NUMBERS DON'T END WITH DOT OR "E"
SKIPN FLTFLG ;FLOATING POINT NUMBER?
JRST [MOVE A,OCTVAL ;NO, GET OCTAL VALUE
CAIN C,"." ;END WITH DECIMAL POINT?
MOVE A,DECVAL ;YES, GET DECIMAL VALUE
JRST AV4]
MOVE A,SYMNA ;FLOATING NUMBER, POINT TO IT
FLIN ;GET FLOATING VALUE
ERROR <Invalid floating point number in expression>
MOVE A,B
AV4: SETO B, ;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
SETZ A, ;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?
ABSKP ;NO
ADDI A,13-"A"(C) ;A TO Z MAPS TO 13 TO 44
CAIL C,"0"
CAILE C,"9"
ABSKP ;CHECK FOR DIGITS
ADDI A,1-"0"(C) ;0 TO 9 MAPS INTO 1 TO 12
JRST ASCR1 ;DO REST OF CHARACTERS
;GVALUE - EVALUATES A SYMBOL.
;
; ACCEPTS: A/ RADIX50 SYMBOL
; B/ 0 OR SPECIFIC MODULE NAME (ALSO RADIX50)
; RETURNS: +1 SYMBOL NOT DEFINED
; +2 A/ VALUE OF SYMBOL
; B/ LOCATION OF VALUE IN SYMBOL TABLE, OR -1 IF OPCODE
GVALUE: STKVAR <FINALF,OPX,WS,GVTAD,MNAME,SPTR,SYMEN2,SAVVAL,SAVVAD>
TXZ A,SCFLD ;CLEAR SYMBOL CODE FIELD
MOVEM A,WS ;REMEMBER WHICH SYMBOL WE'RE LOOKING FOR
MOVEM B,MNAME ;REMEMBER MODULE NAME
CALL CHKSYM ;MAKE SURE SYMBOL TABLE O.K.
MOVE B,MNAME
JUMPE B,SYMV0 ;IF NO PROGRAM NAME, SEARCH ENTIRE TABLE
SETOM FINALF ;IF USING SPECIFIC MODULE NAME, THIS IS FINAL
; PASS
MOVE C,NSYMS ;GET NUMBER OF SYMBOLS
LSH C,1 ;FIND END OF SYMBOL TABLE
ADD C,SYMBEG
SUBI C,2 ;GET TO FIRST POSSIBLE NAME PAIR
MOVEM C,SPTR ;REMEMBER POINTER INTO SYMBOL TABLE
SYMV2: MOVE A,SPTR ;GET POINTER INTO SYMBOL TABLE
CAMGE A,SYMBEG ;IS MODULE NAME IN THE TABLE?
JRST SYMVNO ;MODULE NOT FOUND
CALL GETSYM ;GET NAME AND VALUE
HLRE D,B ;GET NEGATIVE SIZE OF THIS PORTION
CAMN A,MNAME ;HAVE WE FOUND THE CORRECT PROGRAM NAME YET?
JRST [MOVE C,SPTR ;YES, GET ADDRESS OF PROG NAME IN MEMORY
JRST SYMV3]
ADDM D,SPTR ;JUMP TO NEXT PORTION
JRST SYMV2 ;KEEP SEARCHING FOR MODULE
SYMV0: SETZM FINALF ;SAY NO MODULE SUPPLIED, SO THIS ISN'T
; NECESSARILY FINAL PASS
SKIPN A,LASTP ;GET LAST PROGRAM NAME IN WHICH SYMBOL WAS
; FOUND
JRST SYMV4 ;NONE, SO SEARCH ENTIRE TABLE
CALL GETSYM ;GET INFO FROM SYMBOL TABLE
HLRE D,B ;GET NEGATIVE SIZE OF THIS PORTION
MOVE C,LASTP
SYMV3: ADDI C,2
ADD C,D ;GET STARTING ADDRESS OF TABLE FOR THIS MODULE
MOVEM C,GVTAD ;REMEMBER BASE
MOVN D,D ;GET POSITIVE NUMBER OF WORDS
JRST SYMV5 ;GO SEARCH FOR SYMBOL
SYMV4: MOVE D,NSYMS ;GET NUMBER OF SYMBOLS TO SEARCH
SETOM FINALF ;NO PREVIOUS PROGRAM, SO THIS IS FINAL PASS
MOVE A,SYMBEG
MOVEM A,GVTAD ;USE ENTIRE TABLE
LSH D,1 ;COMPUTE NUMBER OF WORDS OF SYMBOL TABLE
; PORTION
SYMV5: ADD D,GVTAD ;COMPUTE ADDRESS ONE TOO LARGE FOR SEGMENT
SOJ D, ;COMPUTE LARGEST ADDRESS IN SEGMENT
MOVEM D,SYMEN2 ;REMEMBER LARGEST ADDRESS
SYMV1: MOVE A,GVTAD ;GET NEXT ADDRESS TO EXAMINE
CAML A,SYMEN2 ;MORE TO LOOK AT?
JRST SYMVNO ;NO
CALL GETSYM ;GET NAME AND VALUE FROM SYMBOL TABLE
LOAD D,SNFLD,A ;GET NAME OF SYMBOL
CAME D,WS ;IS THIS SYMBOL THE RIGHT NAME?
JRST [MOVX 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: MOVX 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
MOVX 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,[ASCPTR A] ;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
SETO B, ;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,[PAGENO SYMBF] ;GET PAGE NUMBER OF SYMBOL BUFFER
HRLI B,.FHSLF ;MAPPING INTO OURSELF
MOVX C,PM%RD!PM%CNT!FLD(NSMPGS,PM%RPT) ;READ ACCESS, NUMBER OF SYMBOL
; PAGES WE HAVE ROOM FOR
PMAP ;ESTABLISH NEW WINDOW INTO SYMBOL TABLE
MOVE A,SYMBA ;GET SMALLEST ADDRESS THAT IS MAPPED
ADDI A,-1+NSMPGS*1000 ;CALCULATE LARGEST ADDRESS MAPPED
MOVEM A,SYMEA ;REMEMBER IT
MOVE A,WA1 ;TRY AGAIN NOW THAT CORRECT CORRECT MAPPING
; ESTABLISHED
JRST GETSYM
;TYPAAC - TYPES ADDRESS AND CONTENTS.
;
; ACCEPTS: A/ ADDRESS
TYPAAC: STKVAR <REMA>
MOVEM A,REMA ;REMEMBER ADDRESS
CALL TYPADD ;TYPE ADDRESS
TYPE </ > ;PUT SLASH AND THREE SPACES AFTER ADDRESS
MOVE A,REMA ;GET ADDRESS AGAIN
CALL RANDOM ;READ CONTENTS
JRST [TYPE <?> ;IF NO CONTENTS, TYPE QUESTION MARK
RET]
CALLRET TYPEXP ;TYPE EXPRESSION SYMBOLICALLY
;TYPADD - TYPES AN ADDRESS AS NAME+N WHERE NAME IS THE SYMBOL WHO'S VALUE IS
; CLOSEST TO AND LESS THAN OR EQUAL TO THE ADDRESS, AND N IS THE REMAINDER.
; "+0" IS NOT PRINTED.
;
; ACCEPTS: A/ ADDRESS
TYPADD::STKVAR <TYPVAL,TYPOFF>
JUMPE A,[TYPE <0> ;HANDLE 0 SPECIALLY
RET]
MOVEM A,TYPVAL ;REMEMBER VALUE
CALL GNT ;GET LOCATION AND NAME OF NEAREST TAG
SUB A,TYPVAL ;COMPUTE OFFSET
MOVNM A,TYPOFF ;REMEMBER POSITIVE OFFSET
CAMLE A,[-1000] ;IF OFFSET 1000 OR MORE, DON'T USE IT
SKIPN A,B ;GET NAME OF SYMBOL
JRST [MOVE A,TYPVAL ;NO SYMBOL, SO JUST TYPE VALUE
ETYPE <%1O>
RET]
CALL TYPSYM ;TYPE SYMBOL NAME
SKIPN A,TYPOFF ;IS THERE AN OFFSET?
RET ;NO, SO WE'RE DONE
TYPE <+> ;YES, SO PUT IN PLUS SIGN
ETYPE <%1O> ;PRINT OCTAL OFFSET
RET ;DONE
;TYPEXP - TYPES OUT AN EXPRESSION SYMBOLICALLY.
;
; ACCEPTS: A/ EXPRESSION
TYPEXP::STKVAR <WINS>
JUMPE A,[TYPE <0>
RET]
MOVEM A,WINS
CALL GNT ;FIRST ATTEMPT EXACT MATCH
CAMN A,WINS ;IS THERE AN EXACT MATCH?
JRST [MOVE A,B ;YES, GET NAME
CALLRET TYPSYM] ;TYPE NAME AND RETURN
MOVE A,WINS
CALL TYPOP ;TYPE THE OPCODE
JUMPE A,TYPHVS ;GO TYPE IN HALFWORDS IF NO OPCODE AT ALL
TYPE < > ;ALWAYS PUT SPACE AFTER OPCODE
TXNE A,ACFLD ;ANY AC FIELD INCLUDED IN OPCODE DEFINITION?
JRST TYPNAC ;YES, SO DON'T ATTEMPT TO PRINT ANOTHER ONE
LOAD A,ACFLD,WINS ;GET AC FIELD
JUMPE A,TYPNAC ;MAYBE NO AC FIELD TO TYPE
CALL SMORNM ;TYPE SYMBOL OR NUMBER
TYPE <,> ;PUT COMMA AFTER AC FIELD
TYPNAC: LOAD A,INDFLD,WINS ;GET INDIRECT BIT
CAIE A,0 ;ANY INDIRECT?
TYPE <@> ;YES, DENOTE IT
LOAD A,YFLD,WINS ;GET Y FIELD
CALL TYPADD ;TYPE Y FIELD SYMBOLICALLY
LOAD A,XFLD,WINS ;GET INDEX FIELD
JUMPE A,R ;DONE IF NONE
TYPE <(>
CALL SMORNM ;TYPE INDEX FIELD
TYPE <)>
RET
;HERE WHEN NO OPCODE WAS FOUND SO WE WANT TO PRINT HALFWORDS.
TYPHVS: HLRZ A,WINS ;GET LEFT HALF OF EXPRESSION
JUMPE A,TYPHV1 ;IF 0, DON'T PRINT IT OR COMMAS
CALL TYPADD ;TYPE AS AN ADDRESS
TYPE <,,> ;DENOTE HALFWORDS
TYPHV1: HRRZ A,WINS ;GET RIGHT HALF OF EXPRESSION
CALLRET TYPADD ;TYPE IT EVEN IF IT'S 0
;TYPSYM - TYPES OUT A SYMBOL NAME.
;
; ACCEPTS: A/ RADIX50 SYMBOL NAME
TYPSYM: CALL R50TAS ;CHANGE TO ASCII
UTYPE A ;TYPE ASCII SYMBOL
RET ;DONE
;ROUTINE CHANGING RADIX50 IN A TO ASCIZ IN A AND B
R50TAS: TLZ A,740000 ;CLEAR JUNK PART
MOVE D,[ASCPTR A] ;MAKE ASCIZ POINTER
CALL R50OUL ;DO THE SYMBOL
SETZ C, ;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?
ABSKP ;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,[ASCPTR A] ;MAKE BYTE POINTER AND SKIP VALUE
ETYPE <%1M> ;TYPE THE SYMBOL
JRST TYPOP2 ;SAY ONLY OPCODE FIELD PRINTED
TYPOP1: MOVE A,B ;PUT NAME OF EXTENDED OPCODE IN A
CALL TYPSYM ;TYPE THE OPCODE
MOVE A,XOPCOD ;GET VALUE OF OPCODE TYPED
TXNE A,ACFLD ;DID OPCODE INCLUDE AN AC FIELD?
JRST [MOVX A,FLD(1,OPFLD)!FLD(1,ACFLD) ;YES, DENOTE THAT THESE FIELDS
; WERE PRINTED
RET]
TYPOP2: MOVX A,FLD(1,OPFLD) ;ONLY OPCODE FIELD PRINTED, SO MARK
RET
;CHKSYM UPDATES SYMBOL TABLE DATABASE IF IT NEEDS IT
CHKSYM: SKIPE SYMOKF ;IS SYMBOL DATABASE OK?
RET ;YES, SO NOTHING TO DO
STKVAR <INSYMP>
SETZM LASTP ;NO CACHED PROGRAM NAME YET
MOVEI A,JOBSYM ;POINT TO SYMBOL TABLE POINTER
CALL RANDOM ;READ SYMBOL TABLE POINTER
JRST [SETZ A, ;ASSUME 0
JRST .+1]
MOVEM A,INSYMP ;REMEMBER POINTER
HRRZM A,SYMBEG ;REMEMBER WHERE SYMBOL TABLE BEGINS
HLRE D,A ;GET NEGATIVE SIZE OF SYMBOL TABLE
LDB A,[PAGENO 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
; +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
NOP ;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> ;7 should this be ERROR?
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,,"
SETZ C, ;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,TXTPTR <)>,<a right parenthesis to end
index register>]
CALL FLDSKP
ERROR <Missing right parenthesis after index register> ;7 no extras
;7 CMERRX <Missing right parenthesis after index register>
IALL: MOVX A,5
CALL GETBUF ;GET BUFFER FOR CONSTITUENTS OF INSTRUCTION
MOVE B,OPPTR
MOVEM B,(A) ;STORE POINTERS TO PARTS IN BUFFER
MOVE B,ACPTR
MOVEM B,1(A) ;OPCODE
MOVE B,INDPTR ;INDIRECT
MOVEM B,2(A)
MOVE B,YPTR
MOVEM B,3(A) ;Y FIELD
MOVE B,XPTR
MOVEM B,4(A) ;X FIELD
RET ;RETURN WITH POINTER TO LIST OF CONSTITUENTS IN
; A
;RCMA, RIND, LPAREN ETC. ALL ATTEMPT TO READ TOKENS SUCH AS COMMA, ATSIGN, LEFT
; PARENTHESIS, SKIPPING IF THE TOKEN IS SEEN.
RCMA: MOVEI B,[FLDDB. .CMTOK,CM%SDH,TXTPTR <,>,<a comma>]
R11: CALLRET XSKP ;PARSE THE TOKEN; GIVE SKIP OR ERROR RETURN
RIND: MOVEI B,[FLDDB. .CMTOK,CM%SDH,TXTPTR <@>,<an atsign (@)>]
JRST R11
LPAREN: CALL RSPACE ;IS SPACE NEXT?
SKIPA B,[[FLDDB. .CMTOK,CM%SDH,TXTPTR <(>,<a left parenthesis>]]
RET ;YES, SO THERE'S NO PARENTHESIS (OTHER THAN
; PERHAPS GUIDE WORDS)
JRST R11 ;NO
RSPACE: MOVEI B,[FLDDB. .CMTOK,CM%SDH,TXTPTR < >,<a space>]
JRST R11
;"FOO FOO" HAS BEEN SEEN, BUT IT'S NOT "FOO FOO,". IT'S EITHER "FOO FOO(" OR
; JUST "FOO FOO".
OANC: MOVE A,ACPTR
MOVEM A,YPTR ;THAT AC IS REALLY A Y FIELD
SETZM ACPTR ;NO AC FIELD ANYMORE
JRST HXM ;GO SEE IF PARENTHESES COMING
;NO OPCODE WAS SEEN, I.E. NO SYMBOL.
NOOPC: SETZM OPPTR ;IF NO SYMBOL FIRST, NO OPCODE OR AC FIELD
CALL RIND ;SEE IF EXPRESSION STARTS WITH ATSIGN
JRST [CALL RCMA ;NO, TRY COMMA
JRST [CALL LPAREN ;NO, TRY PARENTHESIS
ERROR <No opcode seen, and no comma (,) atsign (@)
or parenthesis seen either> ;7 no extra error message
;7 CMERRX <No opcode seen, and no comma (,) atsign (@)
;7 or parenthesis seen either>
SETZM YFLD ;NO Y FIELD
JRST HP ] ;HANDLE PARENTHESES
CALL RCMA ;SEE IF EXPRESSION STARTS WITH TWO COMMAS
JRST SCOMA ;",FOO" EQUALS ",,FOO"
JRST SCOMA]
JRST HI ;HANDLE INDIRECT
;COME HERE WHEN WE DIDN'T SEE "FOO FOO". IT MUST THEREFORE BE "FOO," OR "FOO @"
; OR "FOO (" OR JUST "FOO".
OPNOAC: CALL RIND ;TRY "FOO@"
JRST [CALL RCMA ;NO, HOW ABOUT "FOO,"
JRST [SETZM YPTR ;WE'LL USE OPCODE FOR Y FIELD
CALL LPAREN ;HOW ABOUT "FOO("
JRST IALL ;IT'S JUST "FOO"
JRST HP] ;IT'S JUST "FOO ("
CALL RCMA ;IT'S "FOO,". HOW ABOUT "FOO,,"
JRST [MOVE A,OPPTR ;IT'S JUST "FOO,"
MOVEM A,ACPTR ;SO OPCODE WAS REALLY AN ACCUMULATOR
SETZM OPPTR ;SAY THERE'S NO OPCODE
JRST SCOMA] ;HANDLE INDIRECT MAYBE
MOVE A,OPPTR ;IT'S "FOO,,ZOT" SO "FOO" ISN'T
MOVEM A,XPTR ;REALLY AN OPCODE
SETZM OPPTR ;MARK THAT THERE'S NO OPCODE
JRST SCOMA]
JRST HI ;HANDLE INDIRECT
;RSYM - READS A SYMBOL NAME WHICH MAY BE PRECEDED BY A PROGRAM NAME AND
; 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,[FIRCHR ATMBUF] ;GET FIRST CHARACTER OF SYMBOL READ
CAIE A,0 ;IF NOTHING READ, DON'T SKIP YET
RETSKP
RSYM1: MOVEI B,[FLDDB. .CMTOK,CM%SDH,TXTPTR <[\]>,<"[\]" 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
CAIE C,0 ;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 <Uparrow not implemented yet>
;HERE TO PARSE A SUB-FACTOR. CODE GENERATED RETURNS VALUE IN A.
SUBFAC: CALL PARSYM ;LOOK FOR SYMBOL (AND LEAVE TERMINATOR IN C)
SKIPE SYMBUF ;DID WE GET A SYMBOL?
JRST ISSYM ;YES
CAIN C,"(" ;WANTS TO NEST AN EXPRESSION?
JRST ISEXPR ;YES, GO DO THAT
CALL PARBAD ;OTHERWISE HAS TO BE AN ERROR
ISEXPR: CALL CHRIN ;SKIP OVER THE PARENTHESIS
CALL EXPR ;COMPUTE THE NESTED EXPRESSION
CALL CHRIN ;GET TERMINATOR
CAIE C,")" ;CLOSING PARANTHESIS?
CALLRET PARBAD ;NO, INVALID EXPRESSION
RET ;O.K.
ISNUM: TLCE A,-1 ;SMALL NUMBER?
JRST ISNUM1 ;NO, GO ON
HRLI A,(MOVEI A,) ;YES, FINISH INSTRUCTION
PUSH P1,A ;STORE IT
RET ;DONE
ISNUM1: TLCE A,-1 ;LEFT HALF -1?
JRST ISNUM2 ;NO, TRY OTHER STUFF
TXO A,<HRROI A,> ;YES, FINISH IT
PUSH P1,A ;STORE IT
RET ;DONE
ISNUM2: TRCE A,-1 ;RIGHT HALF ZERO?
JRST ISNUM3 ;NO, GO ON
HLRZ A,A ;YES, GET VALUE
TXO A,<MOVSI A,> ;FINISH INSTRUCTION
PUSH P1,A ;STORE IT
RET ;DONE
ISNUM3: TRCE A,-1 ;RIGHT HALF ONES?
JRST ISNUM4 ;NO, HAVE TO DO HARD WAY
HLRZ A,A ;YES, GET LEFT HALF
TXO A,<HRLOI A,> ;FINISH INSTRUCTION
PUSH P1,A ;SAVE IT
RET ;DONE
ISNUM4: AOS B,DATPTR ;ALLOCATE NEW DATA LOCATION
CAIL B,DATSIZ ;MAKE SURE TABLE HAS ROOM
ERROR <Too many constants typed>
ADDI B,DATA ;GET ADDRESS WHERE DATA GOES
MOVEM A,(B) ;SAVE THE NUMBER
TXO B,<MOVE A,> ;FINISH INSTRUCTION
PUSH P1,B ;STORE IT
RET ;DONE
ISSYM: HRROI A,SYMBUF ;POINT TO MODULE AND SYMBOL PAIR
CALL AVALUE ;GET VALUE OF SYMBOL AND LOCATION OF VALUE
JRST [SETOM EVERRF ;SAY THERE IS AN EVALUATION ERROR
RET]
JUMPL B,ISNUM ;IF B NEGATIVE, IT'S A REAL NUMBER
HRLI B,(<MOVEI A,>) ;MAKE INSTRUCTION TO LOAD UP SYMBOL INFO
; ADDRESS
PUSH P1,B ;PUT LOAD INSTRUCTION ON STACK
PUSH P1,[CALL GSX] ;PUT CALL FOR GETTING VALUE OF SYMBOL
RET
;GSX - IS CALLED BY THE COMPILED CODE TO GET THE VALUE OF A SYMBOL
;
; ACCEPTS: A/ ADDRESS OF SYMBOL INFO
; RETURNS: A/ VALUE OF SYMBOL
GSX: CALL GETSYM ;GET NAME AND VALUE
MOVE A,B ;WE ONLY WANT VALUE
RET
RESCAN: SETOM RFLAG ;RESTORE CURRENT CHAR
RET ;AND RETURN
;ROUTINE TO READ IN A SYMBOL NAME. RETURNS asciz in SYMBUF.
PARSYM: MOVE B,[ASCPTR 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 [SETZ C, ;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,.CHCRT ;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: MOVX 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
SETZ A,
MOVX B,<POINT 36,0,35> ;ACCUMULATE OPCODE INTO ENTIRE WORD
CALL PPART ;PARSE OPCODE
MOVX A,1
MOVX B,<POINTR 0,ACFLD> ;PUT THIS IN AC FIELD
CALL PPART ;GET AC FIELD
MOVX A,2
MOVX B,<POINTR 0,INDFLD> ;PUT INDIRECT IN INDIRECT BIT
CALL PPART
MOVX A,3 ;GET Y FIELD
MOVX B,<POINTR 0,YFLD> ;Y FIELD
CALL PPART
MOVX A,4
MOVX B,<POINT 18,0,17> ;INDEX REGISTER FIELD (MIGHT BE MORE!)
CALL PPART ;GET INDEX FIELD
MOVE A,INSVAL
MOVE B,INSMSK ;GIVE POSSIBLE MASK
SKIPE PERRF ;ANY ERRORS?
RET ;YES, GIVE NONSKIP
RETSKP ;GIVE SUCCESS RETURN
PPART: STKVAR <BP00>
HRRI B,INSVAL ;MAKE COMPLETE BYTE POINTER
MOVEM B,BP00 ;REMEMBER BYTE POINTER
ADD A,AL ;GET ADDRESS OF WORD CONTAINING POINTER
SKIPN A,(A) ;GET POINTER
RET ;NO POINTER, SO LEAVE FIELD ALONE
SKIPE LITF ;SPECIAL LITERAL ALLOWED?
JRST [MOVE B,(A) ;YES, GET POSSIBLE SPECIAL LITERAL
CAME B,[ASCII/[\]/] ;IS IT THE SPECIAL ONE?
JRST .+1 ;NO
SETZ B, ;YES, GET 0 FOR THIS PART OF MASK
MOVE A,BP00 ;GET BYTE POINTER TO INSTRUCTION
HRRI A,INSMSK ;MAKE IT POINT TO MASK
DPB B,A ;CLEAR APPROPRIATE PART OF MASK
RET] ;DONE
CALL EVAL ;GET VALUE OF FIELD
SETOM PERRF ;COULDN'T, MARK AS ERROR
LDB B,BP00 ;GET POSSIBLE DATA
ADD A,B ;ADD IN THE NEW (NEEDED FOR "FOO,,ZOT(3)")
DPB A,BP00 ;STORE RESULT IN APPROPRIATE FIELD
RET
LITSP: ;713 debugging aid: literal label
END