Trailing-Edge
-
PDP-10 Archives
-
SRI_NIC_PERM_SRC_1_19910112
-
6-exec/execpi.b36
There are 2 other files named execpi.b36 in the archive. Click here to see a list.
!<5.1.EXEC>EXECPI.B36.6, 16-Nov-82 05:02:39, Edit by PA0B
!Fix TYPEIN not to raise lowercase (clear TT%LIC for PTY
!in REDFRK), Rewrite PCIKIF to not hang in RELD%.
!Note: PCICLP should be rewritten so that it doesn't do
!most of the thing that PCIKIF does and then call PCIKIF
!to do them again...
!<5.1.EXEC>EXECPI.B36.5, 15-Nov-82 02:38:51, Edit by PA0B
!Make file parses fail if WILD not specified but wildcards
!specified anyway, Allow DISPLAY'ing of integers, Make
!global variable declarations always do something (previously
!they were ignored (unless the declaration was in an .ENV file)
!if another PCL object with the same name as the variable
!already existed, Move PCIRUN to EXECPX, Initialize PCLSTF
!to -1 instead of to PCEOWN.
!<5.1.EXEC>EXECPI.B36.4, 2-Nov-82 08:05:44, Edit by PA0B
!More of previous change: add FK%INV fork flag to keep track
!of which forks are INVOKE'd, Change most things which look
!at FORK to look at PCCURC[ECB_CFK], Fix PCIINF to tolerate
!garbage from .MORLW MTOPR% on an ITY, Fix UNPKEY to sign-extend
!the data value (makes negative values for WORDS work; fix
!courtesy of Charlie Kim at Columbia).
!<5.1.EXEC>EXECPI.B36.3, 4-Aug-82 22:53:31, Edit by PA0B
!Change code which saves/restores FORK to save it only during
!execution of INVOKE and TYPEIN statements (and to restore it
!immediately afterwards. Also save RUNFK.
!<5.1.EXEC>EXECPI.B36.2, 30-May-82 15:40:34, Edit by PA0B
!Don't handle PTY's and PDS's differently in REDFRK, so that
!(hopefully) users of GETTYPEOUT won't have to know which we
!are using, Do RELD% after SCTTY% in PCICLP (under v5.1,
!RELD% hangs if done on a tty which is some fork's controlling
!tty)
!<4.EXEC>EXECPI.B36.103, 7-Mar-82 23:58:38, Edit by PA0B
!Make it so that in the normal case (ie, the PCL command
!does no explicit "Reset" commands and no EXIT TOPROGRAM
!or EXIT SAVE is done) a PCL which does an INVOKE saves
!and restores FORK. This makes it invisible to the user
!whether a particular PCL does an INVOKE. Make INIIVK
!zero STAYF so that we wait for the INVOKE'd fork to halt
!or become hungry even if the last thing we did was to run
!something in the background. Correct foldcasing code in
!PCIDGS (didn't work if name contained digits).
!<4.EXEC>EXECPI.B36.102, 23-Jun-81 14:28:08, Edit by DK32
!New environment file code number
!<4.EXEC>EXECPI.B36.101, 29-Apr-81 16:52:44, Edit by DK32
!Use correct ECB in PCIPSO for DoCommand To output
!<4.EXEC>EXECPI.B36.100, 6-Apr-81 11:05:14, Edit by DK32
!Use correct value from PCIFGS
!<4.EXEC>EXECPI.B36.99, 24-Mar-81 20:03:02, Edit by DK32
!Type the correct part of the buffer in Passoutput mode
!<4.EXEC>EXECPI.B36.98, 14-Mar-81 13:10:10, Edit by DK32
!More ECB initialization
!<4.EXEC>EXECPI.B36.97, 7-Mar-81 18:02:24, Edit by DK32
!Note whether parsing in progress
!<4.EXEC>EXECPI.B36.96, 25-Feb-81 21:52:25, Edit by DK32
!Prompt, Redo symbol replacement, Remove hack for bug
!in old Bliss, PassOutput
!<4.EXEC>EXECPI.B36.95, 7-Jan-81 21:33:16, Edit by DK32
!Close PTY when you kill a fork, Don't kill controlled
!forks which were not Invoked, Make Invoke kill any
!previously Invoked fork, Fix Info PCL line width
!<4.EXEC>EXECPI.B36.94, 22-Dec-80 17:53:51, Edit by DK32
!Use Exec linkage
!<4.EXEC>EXECPI.B36.93, 11-Dec-80 23:54:50, Edit by DK32
!Make preserved context possible
!<4.EXEC>EXECPI.B36.92, 9-Dec-80 21:02:36, Edit by DK32
!Grab hold of current fork if Typein given without Invoke,
!Fix case folding in Set Variable, Option to cleanup not
!to kill fork, Change meaning of PCLGST, Fix Info PCL of
!Undeclare Original
!<4.EXEC>EXECPI.B36.91, 4-Dec-80 15:25:08, Edit by DK32
!Keep command GST in ECB
!<4.EXEC>EXECPI.B36.90, 30-Nov-80 00:35:38, Edit by DK32
!Change some indenting, Save/Exec
!<4.EXEC>EXECPI.B36.89, 11-Nov-80 23:35:14, Edit by DK32
!Change variable handling in environments so common
!subexpression optimization doesn't compile incorrectly,
!Give more detail for synonyms in Info PCL, Handle running
!out of memory in PDS PSI
!<4.EXEC>EXECPI.B36.88, 31-Oct-80 14:40:44, Edit by DK32
!<4.EXEC>EXECPI.B36.87, 29-Oct-80 16:11:27, Edit by DK32
!No initial space from Information Variable, Runtime
!channel list
!<4.EXEC>EXECPI.B36.86, 25-Oct-80 23:02:21, Edit by DK32
!Keep invoked fork in ECB and kill it at cleanup
!<4.EXEC>EXECPI.B36.85, 21-Oct-80 21:58:24, Edit by DK32
!Initialize text area better, Remove Procdefs, Save
!variable values in environments
!<4.EXEC>EXECPI.B36.84, 18-Oct-80 15:53:42, Edit by DK32
!Parse List, Fix Info PCL width code, Unstack parsed JFNs
!<4.EXEC>EXECPI.B36.83, 9-Oct-80 21:29:05, Edit by DK32
!Make parsed JFN list, Don't do reset in Invoke, Observe
!terminal widths in Information PCL
!<4.EXEC>EXECPI.B36.82, 2-Oct-80 15:45:05, Edit by DK32
!Fix Info Variable of empty string variable, Use text
!area for global symbol name strings and values, Add
!Parse NoIndirect
!<4.EXEC>EXECPI.B36.81, 25-Sep-80 21:52:48, Edit by DK32
!Remove SCTTY fudge, Initialize and cleanup runtime I/O
!<4.EXEC>EXECPI.B36.80, 10-Sep-80 14:14:52, Edit by DK32
!Use PCMWTF instead of WAITA, Halt fork before SCTTY,
!Allocate GST only from top, Define null synonyms, New
!Information PCL format, Raise input in PCIDFV, Get all
!output out of control line for each PDS PSI
!<4.EXEC>EXECPI.B36.79, 7-Sep-80 22:19:53, Edit by DK32
!Change PCT to PDS, SIN doesn't give extra null, Initialize
!ECB with no output designator
!<DK32.CG>EXECPI.B36.78, 11-Aug-80 16:12:22, Edit by DK32
!Try to eliminate "Device or data error" on PTY close
!<DK32.CG>EXECPI.B36.77, 8-Aug-80 17:35:58, Edit by DK32
!Keep PCT details in ECB, Parse Number fills $Atom also
!<DK32.CG>EXECPI.B36.76, 5-Aug-80 17:43:19, Edit by DK32
!Use PCT's on Variant 1
!<DK32.CG>EXECPI.B36.75, 1-Aug-80 15:09:35, Edit by DK32
!Fix IOX33 in Typein, Set PTY modes to match real terminal
!<DK32.CG>EXECPI.B36.74, 31-Jul-80 15:22:54, Edit by DK32
!Change PCIKIL to PCICFK to simply disconnect fork from PTY,
!New ENVIR_NUM, Run PTY in full duplex with echoing, Fix Declare errors
!<DK32.CG>EXECPI.B36.73, 19-Jul-80 19:20:07, Edit by DK32
!Synonyms always have a spare word before their name blocks, in case
!they need be abbreviations. Add additional argument to PCMDFO call.
!<DK32.CG>EXECPI.B36.72, 18-Jul-80 14:46:30, Edit by DK32
!Change name of PCIDEV
!<DK32.CG>EXECPI.B36.71, 17-Jul-80 13:22:27, Edit by DK32
!Initialize ECB_DCB
!<DK32.CG>EXECPI.B36.70, 10-Jul-80 10:34:45, Edit by DK32
!Environment files have format number in first word
!<DK32.CG>EXECPI.B36.69, 2-Jul-80 14:02:05, Edit by DK32
!$FILES has device and directory if not default
MODULE EXECPI =
BEGIN
!++
!
! This is the first attempt at the Programmable Command Language interface
!
! Dave King, Carnegie-Mellon University Computation Center
!
! January, 1980
!
! Copyright (C) 1980, Carnegie-Mellon University
!
!--
!++
! This module contains the routines which stand in between the standard
! Exec and the internals of PCL. That, at least, was the original reason
! for this module; it has since become apparent that there is not as much
! need for separation as I once felt. In this module are routines called
! from MACRO code to perform PCL functions, and from inner levels of PCL
! to provide system services.
!--
!
! Standard definitions
!
LIBRARY 'EXECPD';
LIBRARY 'BLI:TENDEF';
LIBRARY 'BLI:MONSYM';
SWITCHES LINKAGE(EXEC);
BUILTIN JSYS,MACHSKIP;
!
! Table of contents:
!
FORWARD ROUTINE
PCINIT: NOVALUE, ! Initialize PCL system
PCIFGS, ! Find global symbol
PCICGS: NOVALUE, ! Create global symbol table entry
PCIDFV: NOVALUE, ! Entry point for DECLARE Integer and String
PCIDFS: NOVALUE, ! Entry point for Synonym definition
PCIWEV: NOVALUE, ! Entry point for WRITE Environment
PCIGEV: NOVALUE, ! Entry point for DECLARE Environment
PCIPSV: NOVALUE, ! Mark all symbols as preserved
PCIUDF, ! Entry point for UNDECLARE
FREESTG: NOVALUE, ! Free memory related to global symbol
PCIINF, ! Entry point for INFORMATION PCL-OBJECTS
PCISGS, ! Entry point for SET VARIABLE
PCIDGS, ! Entry point for INFORMATION VARIABLE
! PCIRUN, ! Entry point for command invocation
PCIPRS, ! Do Parse
UNPFIL, ! Save parsed JFN
UNPUNM: NOVALUE, ! Unparse parsed directory/user name
UNPTAD: NOVALUE, ! Unparse parsed date-time
UNPKEY: NOVALUE, ! Unparse keyword/switch
UNPATM: NOVALUE, ! Copy atom buffer
PRSFLS, ! Do Parse of File List
PCIIVK: NOVALUE, ! Invoke user program
INIIVK: NOVALUE, ! Initialize fork for Invoke
FNDCTY: NOVALUE, ! Get a PDS for PCL
REDFRK: NOVALUE, ! Ready fork
PCICLP: NOVALUE, ! Clean up all JFN's and forks
PCIKIF: NOVALUE, ! Kill invoked fork
PCIRPL: NOVALUE, ! Release Parse JFN list
PCITIN: NOVALUE, ! Type in to user program
WTFPGM, ! Wait for program to require PCL
PCIPEO: NOVALUE, ! Prepare for Exec output
PCIPSO: NOVALUE, ! Handle PTY-output pseudointerrupt
PCIDPY: NOVALUE; ! Display string on real terminal
!
! Macros:
!
MACRO ERROR(TXT) = PCMXER(UPLIT(%ASCIZ TXT)) %;
!
! External references:
!
EXTERNAL ROUTINE
PCCCPL, ! The compiler
PCEXCT: NOVALUE, ! The executer
PCMDFO, ! Define object to regular Exec
PCMUDF: NOVALUE, ! Undefine object in regular Exec
PCMRKT: NOVALUE, ! Require command keyword table size
! PCPRUN: NOVALUE, ! The Procdef execution initializer
PCMPRS, ! Macro-interface Parse routine
SETINV: NOVALUE, ! Set FK%INV in fork table
PCMGJS, ! Get and stack a JFN
PCMITS, ! CVTBDO routine
ECFORK: NOVALUE, ! EXECP routine to create fork
KEFORK: NOVALUE, ! EXECP routine to kill fork
DOGET, ! Support routine to GET%
JUNSTK, ! EXECSU Unstack top JFN on JFN stack
PCMSPN: NOVALUE, ! Set program name
PCMWTF, ! Resume program and wait for it to finish
GTBUFX, ! EXECSU Permanent memory allocate
PCMGMM, ! General memory allocate
PCMGME, ! General memory allocate with error
RETMEM: NOVALUE, ! EXECSU Memory release
SUBBP, ! EXECSU Subtract two byte pointers
LM: NOVALUE, ! EXECSU Get cursor to left margin
DINCLS: NOVALUE, ! EXECPU Close runtime files
PCMSTI, ! CVTDBO routine
PCMXER, ! Execution error
PCMCER; ! Compilation error
EXTERNAL
PCTEXT: VECTOR, ! Pure text region
PCTXFR, ! Pure text free list
PCGBST: GST_TBL, ! Global symbol table
PCLSTF, ! First unused word of run stack
PCLGST, ! Index of next entry to allocate in GST
PCCURC: REF ECB_BLK, ! Current Execution Context Block
%( these should be ecb-specific )%
PCPOTP: VOLATILE, ! Address of block of user program output
PCPEOP: VOLATILE, ! Address of block of Exec output
PCPRGR, ! Flag to indicate controlled program running
PCVVAL, ! System variable VALUE
PCVATM: STR_VAL, ! System variable ATOM
ATMBUF: VECTOR, ! Common COMND% atom buffer
CSBUFP, ! Common string buffer pointer
FORK, ! Common user fork handle
RUNFK, ! Fork handle of running fork
COJFN, ! Preferred output JFN
XDICT, ! Permanent storage pool
STAYF, ! Flag which indicates whether to stay at
! command level when program is run
PCFORK, ! Saved value of FORK
PCRNFK; ! Saved value of RUNFK
EXTERNAL LITERAL
PCTXLN: UNSIGNED(3), ! Length of text area
PCGBLN: UNSIGNED(3), ! Length of global symbol table
PCLCHI: UNSIGNED(6), ! PTY input PSI channel
PCLCHO: UNSIGNED(6), ! PTY output PSI channel
PCEOWN: UNSIGNED(6); ! Number of Executer permanent variables
!
! Equated symbols:
!
LITERAL
ENVIR_NUM = %O'123456000004'; ! Environment file format number
BIND
GBSTLN=PCGBLN*512/GST_LEN; ! Maximum GST index possible
GLOBAL ROUTINE PCINIT: NOVALUE = ! Initialize PCL system
!++
! Functional description:
! Called from EXECPM on first use of PCL. Initializes static
! tables to be filled in by the rest of system, enables SC%SCT.
!
! Formal parameters:
! None
!
! Implicit inputs:
! None
!
! Implicit outputs:
! Text free list, runtime String Space free list, privileges
!
! Routine value:
! None
!
! Side effects:
! None
!--
BEGIN
MAP
PCTEXT: FRE_LST;
REGISTER R1=1,R2=2,R3=3;
IF .PCTXFR EQL 0
THEN
BEGIN
PCTXFR = PCTEXT;
PCTEXT[FRE_CNT] = PCTXLN*512;
PCTEXT[FRE_PTR] = 0
END;
PCLSTF = -1;
R1 = $FHSLF;
JSYS(0,RPCAP,R1,R2,R3);
POINTR(R3,SC_SCT) = 1;
JSYS(0,EPCAP,R1,R2,R3);
PCFORK = -2;
PCRNFK = -2;
END;
GLOBAL ROUTINE PCIFGS(
NAMSTR, ! Stringvalue of desired name
PSVFLG ! Nonzero if preserved entry required
) = ! Find global symbol
!++
! Functional description:
! Locates Global Symbol Table entry for given name, and
! returns its address.
!
! Formal parameters:
! Stringvalue of desired name
! Nonzero if preserved entry required
!
! Implicit inputs:
! Global Symbol Table
!
! Implicit outputs:
! None
!
! Routine value:
! Global Symbol Table entry address, or -1 if not found
!
! Side effects:
! None
!
!--
BEGIN
MAP
NAMSTR: STR_VAL;
DECR I FROM .PCLGST-1 DO
IF .PCGBST[.I,GST_VLD] NEQ 0 THEN
IF .NAMSTR[STV_LEN] EQL .PCGBST[.I,GST_NML] THEN
IF CH$EQL( .NAMSTR[STV_LEN], BYTPTR(.NAMSTR[STV_ADR]),
.NAMSTR[STV_LEN], BYTPTR(.PCGBST[.I,GST_NMA]))
THEN
IF .PSVFLG EQL 0 OR .PCGBST[.I,GST_PSV]
THEN
RETURN PCGBST[.I,GST_VLD]
END;
GLOBAL ROUTINE PCICGS(GS): NOVALUE = ! Create global symbol table entry
!++
! Functional description:
! Given complete description of new global object, creates entry
! for it in global symbol table, and calls Exec to define it
! in its own tables and to confirm the definition to the user.
! If the name is not unique, the old one is replaced.
!
! Formal parameters:
! Address of GST block containing the vital information;
! the GST_NAM field contains the real pointer to be used.
!
! Implicit inputs:
! None
!
! Implicit outputs:
! Global symbol table
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
GST: REF GST_BLK,
DPL;
MAP
GS: REF BLOCK[GST_LEN] FIELD (GST_FLD);
DPL = 0;
GST = PCIFGS(.GS[GST_NAM],0);
IF .GST GTR 0
THEN
BEGIN
DPL = -1;
IF .GST[GST_PSV] THEN GST = 0
END;
IF .GST LEQ 0
THEN
BEGIN
IF .PCLGST GEQ GBSTLN
THEN
PCMCER(UPLIT(%ASCIZ'Global symbol table full'));
GST = PCGBST[.PCLGST,GST_VLD];
PCLGST = .PCLGST + 1
END
ELSE
FREESTG(.GST);
GST[GST_VLD] = .GS[GST_VLD];
GST[GST_VAL] = .GS[GST_VAL];
GST[GST_NAM] = .GS[GST_NAM];
GST[GST_DPL] = .DPL;
PCMDFO(.GS[GST_CLS], .GS[GST_NMA], .DPL, .GS[GST_TXT])
END;
GLOBAL ROUTINE PCIDFV(VARNAM,VARTYP): NOVALUE = ! Define variable
!++
! Functional description:
! Called from EXECPM to perform DECLARE I or S command. Defines global
! variable with given name (case folded) and type and no value.
!
! Formal parameters:
! Stringvalue of name of variable (not case folded)
! 0 for integer, -1 for string
!
! Implicit inputs:
! Global symbol table
!
! Implicit outputs:
! Global symbol table, permanent storage pool
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
IPT, ! String pointers
OPT,
CHR, ! Character
GS: BLOCK[GST_LEN] FIELD(GST_FLD); ! A global symbol entry
MAP
VARNAM: STR_VAL;
IPT = BYTPTR(.VARNAM[STV_ADR]);
OPT = .IPT;
DECR I FROM .VARNAM[STV_LEN] DO
BEGIN
CHR = CH$RCHAR_A(IPT);
IF .CHR GEQ %C'a' AND .CHR LEQ %C'z' THEN CHR = .CHR - %C'a' + %C'A';
CH$WCHAR_A(.CHR,OPT)
END;
! IF PCIFGS(.VARNAM,0) GTR 0 THEN RETURN;
GS[GST_CLS] = GST_CLS_VAR;
GS[GST_TYP] = (IF .VARTYP EQL 0 THEN GST_TYP_INT ELSE GST_TYP_STR);
GS[GST_VAL] = 0;
GS[GST_NML] = .VARNAM[STV_LEN];
GS[GST_NMA] = PCMGMM((.VARNAM[STV_LEN]+5)/5, PCTXFR);
CH$MOVE(.VARNAM[STV_LEN],BYTPTR(.VARNAM[STV_ADR]),BYTPTR(.GS[GST_NAM]));
CH$WCHAR($CHNUL,CH$PTR(.GS[GST_NAM],.VARNAM[STV_LEN]));
PCICGS(GS)
END;
GLOBAL ROUTINE PCIDFS(NAME,ORIG): NOVALUE = ! Define synonym
!++
! Functional description:
! Make a global symbol table entry for a synonym, and
! define it. This may actually be a null definition,
! generated by Undeclare Original.
!
! Formal parameters:
! Stringvalue to synonym name string
! Address of target command name string, or 0
!
! Implicit inputs:
! None
!
! Implicit outputs:
! Global symbol table
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
MAP
NAME: STR_VAL;
LOCAL
PTR,
CNT,
GS: GST_BLK;
IF .ORIG NEQ 0
THEN
BEGIN
CNT = 0;
PTR = BYTPTR(.ORIG);
DO CNT=.CNT+1 WHILE CH$RCHAR_A(PTR) NEQ 0;
GS[GST_PLN] = .CNT;
GS[GST_TXT] = PCMGMM((.CNT+4)/5, PCTXFR);
CH$MOVE(.CNT,BYTPTR(.ORIG),BYTPTR(.GS[GST_TXT]));
END
ELSE
GS[GST_PLN] = GS[GST_TXT] = 0;
GS[GST_CLS] = GST_CLS_SYN;
GS[GST_NML] = .NAME[STV_LEN];
! Must have additional word before string to allow for abbrevations
GS[GST_NMA] = PCMGMM((.NAME[STV_LEN]+10)/5 + 1, PCTXFR) + 1;
CH$MOVE(.NAME[STV_LEN]+1, BYTPTR(.NAME[STV_ADR]), BYTPTR(.GS[GST_NMA]));
PCICGS(GS)
END;
GLOBAL ROUTINE PCIWEV(JFN): NOVALUE = ! Write environment
!++
! Functional description:
! Writes PCL environment on provided file.
!
! Formal parameters:
! JFN of open file
!
! Implicit inputs:
! Commands, procedures, variables, synonyms
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
CMDCNT,
CNT,
GS: REF GST_BLK,
LEN;
MACRO
OUTFILE(WRD) =
BEGIN
REGISTER R1=1,R2=2;
R1 = .JFN;
R2 = WRD;
JSYS(0,BOUT,R1,R2)
END %,
OUTFILES(PTR,LEN) =
BEGIN
REGISTER R1=1,R2=2,R3=3;
R1 = .JFN;
R2 = PTR;
R3 = LEN;
JSYS(0,SOUT,R1,R2,R3)
END %;
! Environment file format number
OUTFILE(ENVIR_NUM);
CMDCNT = 0;
CNT = 0;
INCR I TO .PCLGST-1 DO
BEGIN
LOCAL
CLS,
GS: REF GST_BLK;
GS = PCGBST[.I,GST_VLD];
IF .GS[GST_VLD] NEQ 0
THEN
IF .GS[GST_PSV] EQL 0 OR (.GS[GST_PSV] AND .GS[GST_SPR] EQL 0)
THEN
BEGIN
CNT = .CNT + 1;
CLS = .GS[GST_CLS];
IF .CLS EQL GST_CLS_CMD
OR (.CLS EQL GST_CLS_SYN AND .GS[GST_TXT] NEQ 0)
THEN
CMDCNT=.CMDCNT+1
END
END;
! Number of commands
OUTFILE(.CMDCNT);
! Number of objects
OUTFILE(.CNT);
INCR I TO .PCLGST-1 DO
IF .PCGBST[.I,GST_VLD] NEQ 0 AND ((.PCGBST[.I,GST_PSV] EQL 0) OR
(.PCGBST[.I,GST_PSV] AND .PCGBST[.I,GST_SPR] EQL 0))
THEN
BEGIN
GS = PCGBST[.I,GST_VLD];
! First word of GST entry
OUTFILE(.GS[GST_VLD]);
! Second word of GST entry
OUTFILE(.GS[GST_VAL]);
! Character length of name
OUTFILE(.GS[GST_NML]);
LEN = -(.GS[GST_NML]+5)/5;
! Name
OUTFILES( CH$PTR(.GS[GST_NMA],0,36), .LEN);
LEN = (CASE .GS[GST_CLS] FROM GST_CLS_CMD TO GST_CLS_SYN OF
SET
[GST_CLS_CMD]: .GS[GST_COD] + .GS[GST_CNS]
+ .GS[GST_SML]*STE_LEN;
[GST_CLS_PRC,
GST_CLS_FCN]: .GS[GST_COD] + .GS[GST_PCT] + .GS[GST_CNS]
+ .GS[GST_SML]*STE_LEN;
[GST_CLS_VAR]: IF .GS[GST_TYP] EQL GST_TYP_INT
THEN
0
ELSE
BEGIN
LOCAL
STR: STR_VAL;
STR = .GS[GST_VAL];
(.STR[STV_LEN]+4)/5
END;
[GST_CLS_SYN]: (.GS[GST_PLN]+4)/5
TES);
IF .LEN NEQ 0
THEN
! Text
BEGIN
LOCAL
SRC;
IF .GS[GST_CLS] EQL GST_CLS_VAR
THEN
BEGIN
LOCAL
STR: STR_VAL;
STR = .GS[GST_VAL];
SRC = .STR[STV_ADR]
END
ELSE
SRC = .GS[GST_TXT];
OUTFILES( CH$PTR(.SRC,0,36), -.LEN)
END
END
END;
GLOBAL ROUTINE PCIGEV(JFN): NOVALUE = ! Define environment
!++
! Functional description:
! Reads an environment file and defines all the PCL objects
! contained therein.
!
! Formal parameters:
! JFN of open file
!
! Implicit inputs:
! None
!
! Implicit outputs:
! Commands, procedures, variables, synonyms
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
CNT, ! Object count
LEN,
GS: BLOCK[GST_LEN] FIELD (GST_FLD); ! A global symbol entry
MACRO
INFILE =
BEGIN
REGISTER R1=1,R2=2;
R1 = .JFN;
JSYS(0,BIN,R1,R2);
.R2
END %,
INFILES (PTR,CNT) =
BEGIN
REGISTER R1=1,R2=2,R3=3;
R1 = .JFN;
R2 = PTR;
R3 = CNT;
JSYS(0,SIN,R1,R2,R3)
END %;
! Environment file format number
IF INFILE NEQ ENVIR_NUM
THEN
PCMCER(UPLIT(%ASCIZ 'File is not compatible environment file'));
! Number of commands and synonyms
CNT = INFILE;
IF .CNT NEQ 0
THEN
PCMRKT(.CNT);
! Number of objects
CNT = INFILE;
WHILE
.CNT GTR 0
DO
BEGIN
! First word of GST entry
GS[GST_VLD] = INFILE;
! Second word of GST entry
GS[GST_VAL] = INFILE;
! Character length of name
GS[GST_NML] = INFILE;
LEN = (.GS[GST_NML]+5)/5;
IF .GS[GST_CLS] EQL GST_CLS_SYN
THEN
! Extra word in case a synonym entry must be made
GS[GST_NMA] = PCMGMM(.LEN+1, PCTXFR) + 1
ELSE
GS[GST_NMA] = PCMGMM(.LEN, PCTXFR);
! Name
INFILES(CH$PTR(.GS[GST_NMA],0,36), -.LEN);
LEN = (CASE .GS[GST_CLS] FROM GST_CLS_CMD TO GST_CLS_SYN OF
SET
[GST_CLS_CMD]: .GS[GST_COD] + .GS[GST_CNS] + .GS[GST_SML]*STE_LEN;
[GST_CLS_PRC,
GST_CLS_FCN]: .GS[GST_COD] + .GS[GST_PCT] + .GS[GST_CNS]
+ .GS[GST_SML]*STE_LEN;
[GST_CLS_VAR]: IF .GS[GST_TYP] EQL GST_TYP_STR
THEN
BEGIN
LOCAL
STR: STR_VAL;
STR = .GS[GST_VAL];
(.STR[STV_LEN]+4)/5
END
ELSE
0;
[GST_CLS_SYN]: (.GS[GST_PLN]+4)/5
TES);
IF .LEN NEQ 0
THEN
BEGIN
LOCAL
DST;
DST = PCMGMM(.LEN, PCTXFR);
! Text or value of string variable
INFILES( CH$PTR(.DST,0,36), -.LEN);
IF .GS[GST_CLS] EQL GST_CLS_VAR
THEN
BEGIN
LOCAL
STR: STR_VAL;
STR = .GS[GST_VAL];
STR[STV_ADR] = .DST;
GS[GST_VAL] = .STR
END
ELSE
GS[GST_TXT] = .DST
END;
PCICGS(GS);
CNT = .CNT - 1
END
END;
GLOBAL ROUTINE PCIPSV: NOVALUE = ! Mark all symbols as preserved
!++
! Functional description:
! Mark all symbols as preserved.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Symbol table
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
DECR I FROM .PCLGST-1 DO
IF .PCGBST[.I,GST_VLD] NEQ 0 THEN
PCGBST[.I,GST_PSV] = 1;
GLOBAL ROUTINE PCIUDF(NAMPTR) = ! Undefine global object
!++
! Functional description:
! Removes global symbol table entry for given object,
! and frees all storage associated with it. If object
! is preserved, sets object to be superceded. If object
! was a duplicate, find the preserved object with the
! same name and un-supercede it.
!
! Formal parameters:
! Stringvalue of name of object
!
! Implicit inputs:
! Global symbol table
!
! Implicit outputs:
! Global symbol table, Text area, permanent storage pool
!
! Routine value:
! TRUE if undefined, FALSE if not defined
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
GS: REF GST_BLK, ! Entry being deleted
PRESRV: REF GST_BLK; ! Formerly superceded entry
MAP
NAMPTR: STR_VAL;
PRESRV = 0;
GS = PCIFGS(.NAMPTR,0);
IF .GS LEQ 0 THEN RETURN FALSE;
IF .GS[GST_PSV]
THEN
BEGIN
GS[GST_SPR] = 1;
RETURN FALSE
END;
IF .GS[GST_DPL]
THEN
DECR I FROM .PCLGST-1 DO
IF .PCGBST[.I,GST_VLD] NEQ 0 THEN
IF .PCGBST[.I,GST_PSV] THEN
IF .GS[GST_NML] EQL .PCGBST[.I,GST_NML] THEN
IF CH$EQL(.GS[GST_NML], BYTPTR(.GS[GST_NMA]),
.GS[GST_NML], BYTPTR(.PCGBST[.I,GST_NMA]))
THEN
BEGIN
PRESRV = PCGBST[.I,GST_VLD];
EXITLOOP
END;
FREESTG(.GS);
PCMUDF(.GS[GST_CLS],.GS[GST_NMA]);
IF .PRESRV NEQ 0
THEN
BEGIN
PRESRV[GST_SPR] = 0;
PCMDFO(.PRESRV[GST_CLS], .PRESRV[GST_NMA], 0, .PRESRV[GST_TXT])
END;
IF .GS[GST_CLS] EQL GST_CLS_SYN
THEN
RETMEM((.GS[GST_NML]+10)/5, .GS[GST_NMA]-1, PCTXFR)
ELSE
RETMEM((.GS[GST_NML]+5)/5, .GS[GST_NMA], PCTXFR);
GS[GST_VLD] = 0;
TRUE
END;
ROUTINE FREESTG(
GS: REF GST_BLK ! Address of GST entry to release
): NOVALUE = ! Free memory relating to global symbol
!++
! Functional description:
! Releases all storage associated with a global symbol entry.
!
! Formal parameters:
! Address of global symbol table entry
!
! Implicit inputs:
! None
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
CASE .GS[GST_CLS] FROM GST_CLS_CMD TO GST_CLS_SYN OF
SET
[GST_CLS_CMD]: RETMEM( .GS[GST_COD] + .GS[GST_CNS] + .GS[GST_SML]*STE_LEN,
.GS[GST_TXT],PCTXFR);
[GST_CLS_PRC,
GST_CLS_FCN]: RETMEM( .GS[GST_COD] + .GS[GST_PCT] + .GS[GST_CNS]
+ .GS[GST_SML]*STE_LEN,
.GS[GST_TXT], PCTXFR);
[GST_CLS_VAR]: IF .GS[GST_TYP] EQL GST_TYP_STR
THEN
BEGIN
LOCAL
STR: STR_VAL; ! String value
STR = .GS[GST_VAL];
GS[GST_VAL] = 0;
IF .STR NEQ 0
THEN
RETMEM((.STR[STV_LEN]+5)/5, .STR[STV_ADR], PCTXFR)
END;
[GST_CLS_SYN]: IF .GS[GST_PLN] NEQ 0 THEN RETMEM( (.GS[GST_PLN]+4)/5,
.GS[GST_TXT], PCTXFR)
TES
END;
GLOBAL ROUTINE PCIINF = ! Entry point for INFORMATION PCL
!++
! Functional description:
! Generate a string containing a line for each object class,
! containing the name of each object in the class. Return
! the string, in a form suitable for display by UTYPE.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Global symbol table
!
! Implicit outputs:
! String buffer CSBUF
!
! Routine value:
! Address of string buffer, or zero
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
PTR, ! Character pointer
IPTR,
BUF: STR_VAL, ! Buffer
WIDTH, ! Terminal width
LEN, ! Length of current line
ENTRY: VECTOR[10], ! A single entry
EPTR, ! Pointer in entry
ELEN, ! Length of entry
CNT, ! Count of names on this line
CHR; ! Character
BEGIN
REGISTER R1=1,R2=2,R3=3;
R1 = .COJFN;
R2 = $MORLW;
JSYS(-1,MTOPR,R1,R2,R3);
WIDTH = .R3;
IF .WIDTH GEQ 10000 ! In case foonly PDS...
THEN
WIDTH = 0;
END;
BUF = .CSBUFP;
BUF = .BUF[STV_ADR] + 1;
PTR = BYTPTR(.BUF);
LEN = 0;
INCR I FROM GST_CLS_CMD TO GST_CLS_SYN DO
BEGIN
CNT = 0;
INCR J FROM 0 TO .PCLGST-1 DO
IF .PCGBST[.J,GST_VLD] NEQ 0 AND .PCGBST[.J,GST_CLS] EQL .I
THEN
BEGIN
IF .CNT EQL 0
THEN
BEGIN
IPTR = (CASE .I FROM GST_CLS_CMD TO GST_CLS_SYN OF
SET
[GST_CLS_CMD]: CH$PTR(UPLIT(%ASCIZ ' Commands:'));
[GST_CLS_PRC]: CH$PTR(UPLIT(%ASCIZ ' Procedures:'));
[GST_CLS_FCN]: CH$PTR(UPLIT(%ASCIZ ' Typed Procedures:'));
[GST_CLS_VAR]: CH$PTR(UPLIT(%ASCIZ ' Variables:'));
[GST_CLS_SYN]: CH$PTR(UPLIT(%ASCIZ ' Command name manipulations:'))
TES);
WHILE
(CHR=CH$RCHAR_A(IPTR)) NEQ 0
DO
BEGIN
CH$WCHAR_A(.CHR,PTR);
LEN = .LEN + 1
END
END;
EPTR = BYTPTR(ENTRY);
ELEN = 1;
CH$WCHAR_A(%C' ',EPTR);
IF .CNT GEQ 1
THEN
BEGIN
CH$WCHAR_A(%C',',PTR);
LEN = .LEN + 1
END;
CNT = .CNT + 1;
IF .I EQL GST_CLS_FCN OR .I EQL GST_CLS_VAR
THEN
BEGIN
IF .PCGBST[.J,GST_TYP] EQL GST_TYP_INT
THEN
IPTR = CH$PTR(UPLIT(%ASCIZ 'Integer '))
ELSE
IPTR = CH$PTR(UPLIT(%ASCIZ 'String '));
WHILE
(CHR=CH$RCHAR_A(IPTR)) NEQ 0
DO
BEGIN
CH$WCHAR_A(.CHR,EPTR);
ELEN = .ELEN + 1
END
END;
IF .I EQL GST_CLS_FCN
THEN
BEGIN
IPTR = CH$PTR(UPLIT(%ASCIZ 'Procedure '));
WHILE
(CHR=CH$RCHAR_A(IPTR)) NEQ 0
DO
BEGIN
CH$WCHAR_A(.CHR,EPTR);
ELEN = .ELEN + 1
END
END
ELSE
IF .I EQL GST_CLS_SYN
THEN
BEGIN
IF .PCGBST[.J,GST_PLN] NEQ 0
THEN
IPTR = CH$PTR(UPLIT(%ASCIZ 'Synonym '))
ELSE
IPTR = CH$PTR(UPLIT(%ASCIZ 'Undeclare Original '));
WHILE
(CHR=CH$RCHAR_A(IPTR)) NEQ 0
DO
BEGIN
CH$WCHAR_A(.CHR,EPTR);
ELEN = .ELEN + 1
END
END;
IPTR = BYTPTR(.PCGBST[.J,GST_NMA]);
WHILE
(CHR = CH$RCHAR_A(IPTR)) NEQ 0
DO
BEGIN
CH$WCHAR_A(.CHR, EPTR);
ELEN = .ELEN + 1
END;
IF .PCGBST[.J,GST_PSV]
THEN
BEGIN
CH$WCHAR_A(%C'$', EPTR);
ELEN = .ELEN + 1;
IF .PCGBST[.J,GST_SPR]
THEN
BEGIN
CH$WCHAR_A(%C'*', EPTR);
ELEN = .ELEN + 1
END
END;
IF .I EQL GST_CLS_SYN AND .PCGBST[.J,GST_PLN] NEQ 0
THEN
BEGIN
CH$WCHAR_A(%C'=', EPTR);
ELEN = .ELEN + 1;
IPTR = BYTPTR(.PCGBST[.J,GST_TXT]);
WHILE
(CHR = CH$RCHAR_A(IPTR)) NEQ 0
DO
BEGIN
CH$WCHAR_A(.CHR, EPTR);
ELEN = .ELEN + 1
END
END;
IF .LEN + .ELEN GEQ .WIDTH
THEN
BEGIN
CH$WCHAR_A(%C'%',PTR);
CH$WCHAR_A(%C'_',PTR);
CH$WCHAR_A(%C' ',PTR);
LEN = 1
END;
CH$WCHAR_A(0,EPTR);
EPTR = BYTPTR(ENTRY);
WHILE (CHR=CH$RCHAR_A(EPTR)) NEQ 0 DO CH$WCHAR_A(.CHR,PTR);
LEN = .LEN + .ELEN
END;
IF .CNT NEQ 0
THEN
BEGIN
CH$WCHAR_A(%C'%',PTR);
CH$WCHAR_A(%C'_',PTR);
LEN = 0
END
END;
IF .PTR NEQ BYTPTR(.BUF)
THEN
BEGIN
CH$WCHAR_A($CHNUL,PTR);
.BUF
END
ELSE
0
END;
GLOBAL ROUTINE PCISGS(NAME,TYPE,VALUE) = ! Entry point for SET VARIABLE
!++
! Functional description:
! Perform Set Variable command, depositing given datum in
! global variable. If datum is a string, copy it to the
! text region.
!
! Formal parameters:
! Pointer to ASCIZ string of (unfolded) variable name
! Expected variable type: -1=string, 0=integer
! Datum to store
!
! Implicit inputs:
! Global symbol table
!
! Implicit outputs:
! Global symbol table, text region
!
! Routine value:
! +1 if successful, 0 if no such variable, -1 if wrong type
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
MAP
NAME: STR_VAL,
VALUE: STR_VAL;
LOCAL
PTR, ! String pointer
CNT, ! Counter
CHR, ! Character
SYM: STR_VAL, ! String value of symbol
GST: REF GST_BLK; ! GST address of symbol
PTR = .NAME;
CNT = -1;
DO
BEGIN
CHR = CH$RCHAR(.PTR);
IF .CHR GEQ %C'a' AND .CHR LEQ %C'z' THEN CHR = .CHR - %C'a' + %C'A';
CH$WCHAR_A(.CHR, PTR);
CNT = .CNT + 1
END
WHILE
.CHR NEQ 0;
SYM[STV_LEN] = .CNT;
SYM[STV_ADR] = .NAME[STV_ADR];
GST = PCIFGS(.SYM,0);
IF .GST LEQ 0 THEN RETURN 0;
IF .GST[GST_CLS] NEQ GST_CLS_VAR THEN RETURN 0;
CASE .GST[GST_TYP] FROM GST_TYP_INT TO GST_TYP_STR OF
SET
[GST_TYP_INT]: BEGIN
IF .TYPE NEQ 0 THEN RETURN -1;
GST[GST_VAL] = .VALUE
END;
[GST_TYP_STR]: BEGIN
IF .TYPE EQL 0 THEN RETURN -1;
IF .GST[GST_VAL] NEQ 0
THEN
BEGIN
SYM = .GST[GST_VAL];
RETMEM((.SYM[STV_LEN]+5)/5, .SYM[STV_ADR], PCTXFR)
END;
IF .VALUE[STV_LEN] EQL 0
THEN
GST[GST_VAL] = 0
ELSE
BEGIN
SYM = PCMGMM((.VALUE[STV_LEN]+5)/5, PCTXFR);
CH$MOVE(.VALUE[STV_LEN]+1,
BYTPTR(.VALUE[STV_ADR]),BYTPTR(.SYM));
SYM[STV_LEN] = .VALUE[STV_LEN];
GST[GST_VAL] = .SYM
END
END;
TES;
1
END;
GLOBAL ROUTINE PCIDGS(NAME) = ! Entry point for INFORMATION VARIABLE
!++
! Functional description:
! Get value of global variable and return it in printable form.
!
! Formal parameters:
! Pointer to ASCIZ string of unfolded variable name
!
! Implicit inputs:
! Global symbol table
!
! Implicit outputs:
! CSBUF
!
! Routine value:
! Address of ASCIZ string containing value, or -1 if no such symbol
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
MAP
NAME: STR_VAL;
LOCAL
PTR, ! String pointer
CNT, ! Counter
CHR, ! Character
STR: STR_VAL, ! Stringvalue
BUF: STR_VAL, ! Pointer to string being returned
GST: REF GST_BLK; ! GST entry of variable
PTR = .NAME;
CNT = -1;
DO
(CHR=CH$RCHAR(.PTR);
IF .CHR GEQ %C'a' AND .CHR LEQ %C'z' THEN CHR = .CHR AND %O'137';
CH$WCHAR_A(.CHR,PTR);
CNT=.CNT+1)
WHILE
.CHR NEQ 0;
STR[STV_LEN] = .CNT;
STR[STV_ADR] = .NAME[STV_ADR];
GST = PCIFGS(.STR,0);
IF .GST LEQ 0 THEN RETURN -1;
IF .GST[GST_CLS] NEQ GST_CLS_VAR THEN RETURN -1;
BUF = .CSBUFP;
BUF = .BUF[STV_ADR] + 1;
PTR = BYTPTR(.BUF);
IF .GST[GST_TYP] EQL GST_TYP_INT
THEN
BEGIN
PTR = PCMITS(.GST[GST_VAL],.PTR);
CH$WCHAR($CHNUL,.PTR)
END
ELSE
IF .GST[GST_VAL] NEQ 0
THEN
BEGIN
STR = .GST[GST_VAL];
CH$MOVE(.STR[STV_LEN]+1,BYTPTR(.STR[STV_ADR]),.PTR)
END
ELSE
CH$WCHAR($CHNUL,.PTR);
.BUF
END;
GLOBAL ROUTINE PCIPRS(FLDDB,OPTFLG,PMTSTR) = ! Do Parse
!++
! Functional description:
! Parses a field from the original command line which invoked
! the command procedure, according to the FLDDB chain provided
! by the user's procedure. I call the macro-interface COMND%
! routine to do the COMND% in the proper context. If the parse
! succeeds, I save appropriate information in standard variables
! so the user can get things like number typed, keyword entered,
! etc., by using further system calls. I return the real address
! of the FLDDB which succeeded, or a negative error indication.
!
! Formal parameters:
! Address of the first FLDDB, or zero for .CMINI
! Option flag: Low bit set to handle reparse, next bit set
! to allow indirect files; echo control for .CMINI
! For .CMINI, pointer to prompt string
!
! Implicit inputs:
! None
!
! Implicit outputs:
! System variables
!
! Routine value:
! Address of successful FLDDB, or -1 if none succeeded,
! or -2 if a reparse happened
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
SUCC, ! Address of successful FLDDB
RETR2; ! R2 at exit from COMND%
IF .FLDDB EQL 0 THEN RETURN PCMPRS(0,.PMTSTR,.OPTFLG);
IF .POINTR((.FLDDB+$CMFNP),CM_FNC) EQL $CMFLS
THEN
SUCC = PRSFLS(.FLDDB,.OPTFLG)
ELSE
SUCC = PCMPRS(.FLDDB,RETR2,.OPTFLG);
IF .SUCC GTR 0
THEN
CASE .POINTR((.SUCC+$CMFNP),CM_FNC) FROM $CMKEY TO $CMFLS OF
SET
[$CMKEY,
$CMSWI]: UNPKEY(.RETR2);
[$CMNUM]: BEGIN
PCVVAL = .RETR2;
UNPATM()
END;
[$CMIFI,
$CMOFI,
$CMFIL]: SUCC = UNPFIL(.RETR2,.SUCC);
[$CMFLD,
$CMDEV,
$CMTXT,
$CMQST,
$CMNOD]: UNPATM();
[$CMDIR,
$CMUSR]: UNPUNM(.RETR2,.SUCC);
[$CMTAD]: UNPTAD(.RETR2,.SUCC);
[INRANGE]: ;
TES;
.SUCC
END;
ROUTINE UNPFIL(RETR2,SUCC) = ! Save parsed JFN
!++
! Functional description:
! Save JFN returned by COMND% in list in ECB.
!
! Formal parameters:
! JFN
! Address of successful FLDDB
!
! Implicit inputs:
! ECB
!
! Implicit outputs:
! None
!
! Routine value:
! .SUCC if successful, -1 if error (wildcard given when not allowed)
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
LST: REF JLS_WRD; ! JFN list pointer
PCIRPL();
IF .POINTR((.SUCC+$CMFNP),CM_WLD) EQL 0
THEN
IF (.RETR2 AND (GJ_DEV OR GJ_DIR OR GJ_NAM OR GJ_EXT OR GJ_VER)) NEQ 0
THEN
BEGIN
REGISTER R1=1,R2=2;
R1 = $FHSLF;
R2 = DESX7;
JSYS(0,SETER,R1,R2);
RETURN -1; ! Error if wildcards given but not allowed
END;
LST = PCMGMM(2, XDICT);
PCCURC[ECB_PFL] = .LST;
LST[JLS_JFN] = .RETR2;
LST[JLS_LNK] = 0;
LST[JLS_WLD] = .POINTR((.SUCC+$CMFNP),CM_WLD);
JUNSTK();
.SUCC
END;
ROUTINE UNPUNM(RETR2,SUCC): NOVALUE = ! Unparse directory/user name
!++
! Functional description:
! Given directory or user number returned by COMND%, store the
! corresponding directory or user name in the atom buffer and
! copy it into $ATOM.
!
! Formal parameters:
! Directory/user number
! Address of successful FLDDB
!
! Implicit inputs:
! None
!
! Implicit outputs:
! $ATOM
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
IF .POINTR((.SUCC+$CMFNP),CM_PO) EQL 0
THEN
BEGIN
REGISTER R1=1,R2=2;
R1 = CH$PTR(ATMBUF);
R2 = .RETR2;
IF NOT JSYS(1,DIRST,R1,R2) THEN ATMBUF = 0
END;
UNPATM()
END;
ROUTINE UNPTAD(RETR2,FDB): NOVALUE = ! Unparse parsed date-time
!++
! Functional description:
! Store parsed date and time in atom buffer, copy to $ATOM.
! Store internal date and time as integer in $VALUE.
!
! Formal parameters:
! Internal date and time returned by COMND%
! Address of the .CMTAD FLDDB
!
! Implicit inputs:
! None
!
! Implicit outputs:
! $ATOM, $VALUE
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
MAP
FDB: REF VECTOR; ! FLDDB
BEGIN
REGISTER R1=1,R2=2,R3=3;
R1 = CH$PTR(ATMBUF);
R2 = .RETR2;
R3 = 0;
IF .POINTR((FDB[$CMDAT]),CM_IDA) EQL 0 THEN R3 = .R3 + OT_NDA;
IF .POINTR((FDB[$CMDAT]),CM_ITM) EQL 0 THEN R3 = .R3 + OT_NTM;
JSYS(0,ODTIM,R1,R2,R3)
END;
PCVVAL = .RETR2;
UNPATM()
END;
ROUTINE UNPKEY(RETR2): NOVALUE = ! Unparse keyword/switch
!++
! Functional description:
! Fill in $ATOM and $VALUE with keyword/switch text and value.
!
! Formal parameters:
! Address of successful entry in table
!
! Implicit inputs:
! None
!
! Implicit outputs:
! $ATOM, $VALUE
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
HW: HLF_WRD,
PTRI,
PTRO,
CHR;
HW = ..RETR2;
PCVVAL = .HW<0,18,1>; ! Get and sign-extend the value
PTRI = BYTPTR(.HW[HLF_LFT]);
PTRO = BYTPTR(ATMBUF);
DO (CHR = CH$RCHAR_A(PTRI); CH$WCHAR_A(.CHR,PTRO)) UNTIL .CHR EQL $CHNUL;
UNPATM()
END;
ROUTINE UNPATM: NOVALUE = ! Copy atom buffer
!++
! Functional description:
! Copy current contents of atom buffer into permanent storage
! block; replace $ATOM with it.
!
! Formal parameters:
! None
!
! Implicit inputs:
! ATMBUF
!
! Implicit outputs:
! PCVATM
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
CNT, ! Character count
PTR; ! String pointer
IF .PCVATM NEQ 0
THEN
RETMEM((.PCVATM[STV_LEN]+5)/5, .PCVATM[STV_ADR], XDICT);
CNT = 0;
PTR = BYTPTR(ATMBUF);
WHILE CH$RCHAR_A(PTR) NEQ $CHNUL DO CNT = .CNT + 1;
PCVATM[STV_LEN] = .CNT;
PTR = GTBUFX((.CNT+5)/5);
PCVATM[STV_ADR] = .PTR;
CH$MOVE(.CNT+1, CH$PTR(ATMBUF), BYTPTR(.PTR))
END;
ROUTINE PRSFLS(FDB,OPTFLG) = ! Do Parse File List
!++
! Functional description:
! Do processing for parsing a file list. This routine gets the names
! parsed and stores the JFN list.
!
! Formal parameters:
! Address of the FLDDB
! Option flag to pass to PCMPRS
!
! Implicit inputs:
! None
!
! Implicit outputs:
! Parsed JFN list
!
! Routine value:
! Address of FLDDB, or -1 if a file parse failed, or -2 for reparse
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
RETR2; ! R2 returned from COMND
MAP
FDB: REF VECTOR; ! FLDDB
BIND
CMA_FLDDB = UPLIT($CMCMA^27,0,0,0);
PCIRPL();
POINTR((FDB[$CMFNP]),CM_FNC) = $CMFIL;
DO
BEGIN
LOCAL
LST: REF JLS_WRD, ! List pointers
ENT: REF JLS_WRD,
VAL;
VAL = PCMPRS(.FDB,RETR2,.OPTFLG);
IF .VAL LSS 0 THEN RETURN .VAL;
!!! The following makes FILELIST fail if WILD was not specified in the
!!! parse. To make this work, put this code back in and don't set GJ%IFG
!!! automatically if user does a PARSE FILELIST. This code is out at the
!!! moment 'cause it might break many things and I'm not sure it is a good
!!! idea anyway:
!!! IF .POINTR((FDB[$CMFNP]),CM_WLD) EQL 0
!!! THEN
!!! IF (.RETR2 AND (GJ_DEV OR GJ_DIR OR GJ_NAM OR GJ_EXT OR GJ_VER))
!!! NEQ 0
!!! THEN
!!! BEGIN
!!! REGISTER R1=1,R2=2;
!!! R1 = $FHSLF;
!!! R2 = DESX7;
!!! JSYS(0,SETER,R1,R2);
!!! RETURN -1; ! Error if wildcards given but not allowed
!!! END;
ENT = PCMGMM(2, XDICT);
ENT[JLS_JFN] = .RETR2;
ENT[JLS_LNK] = 0;
ENT[JLS_WLD] = .POINTR((FDB[$CMFNP]),CM_WLD);
JUNSTK();
LST = .PCCURC[ECB_PFL];
IF .LST EQL 0
THEN
PCCURC[ECB_PFL] = .ENT
ELSE
BEGIN
WHILE .LST[JLS_LNK] NEQ 0 DO LST=.LST[JLS_LNK];
LST[JLS_LNK] = .ENT
END
END
UNTIL
BEGIN
LOCAL VAL;
VAL = PCMPRS(CMA_FLDDB,RETR2,.OPTFLG);
IF .VAL EQL -2 THEN RETURN -2;
.VAL LSS 0
END;
POINTR((FDB[$CMFNP]),CM_FNC) = $CMFLS;
.FDB
END;
GLOBAL ROUTINE PCIIVK(PTR,PASS): NOVALUE = ! Invoke user program
!++
! Functional description:
! Get and start up user program under control of PCL. This is called
! by executing an Invoke statement, with the user providing a string
! which contains the name of an executable file. I run the program
! in much the same fashion as if the user had issued a Run command,
! the only (desired) exception being that the program's controlling
! terminal (and primary I/O designators) are redirected to a PTY for
! PCL control. After starting the program, I wait for the program to
! either halt or require terminal input, at which time PCL execution
! proceeds. While running, the terminal may well write to its primary
! output; this will be read from the PTY and saved in the program output
! buffer for the user to see, unless PassOutput is specified, in which
! case it is typed immediately.
!
! Formal parameters:
! Stringvalue of string containing name of file to execute
! Nonzero to pass output without buffering
!
! Implicit inputs:
! None
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
JFN, ! JFN on PDS
NUM; ! Number of PDS
PCFORK = .FORK; ! Save old value of FORK
PCRNFK = .RUNFK; ! and RUNFK
INIIVK(.PTR);
IF .PCCURC[ECB_CTN] EQL 0
THEN
BEGIN
FNDCTY(JFN,NUM);
PCCURC[ECB_CTN] = .NUM;
PCCURC[ECB_CTJ] = .JFN
END;
PCCURC[ECB_PAS] = .PASS;
REDFRK(1);
WTFPGM();
FORK = .PCFORK;
RUNFK = .PCRNFK;
PCFORK = -2;
PCRNFK = -2;
END;
ROUTINE INIIVK(NAMVAL): NOVALUE = ! Initialize fork for Invoke
!++
! Functional description:
! Does fork initialization for Invoke statement: Gets and stacks
! program JFN, clears out program environment (like a Reset command),
! makes a fork, and gets the program into the fork. Zeroes STAYF so
! that the fork does not run in the background.
!
! Formal parameters:
! Stringvalue of string containing program name
!
! Implicit inputs:
! None
!
! Implicit outputs:
! FORK
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
JFN, ! JFN
CNT, ! Counter
HLFTMP: HLF_WRD, ! Temporary
GJBLK: VECTOR[$GJF2]; ! Long GTJFN% block
MAP
NAMVAL: STR_VAL; ! Argument
DECR I FROM $GJJFN DO GJBLK[.I] = 0;
GJBLK[$GJGEN] = GJ_OLD;
GJBLK[$GJSRC] = $NULIO ^ 18 + $NULIO;
GJBLK[$GJEXT] = CH$PTR(UPLIT(%ASCIZ 'EXE'));
JFN = PCMGJS(GJBLK[0], BYTPTR(.NAMVAL[STV_ADR]));
IF .JFN LSS 0 THEN ERROR('Unable to get file');
PCIKIF();
ECFORK();
PCCURC[ECB_CFK] = .FORK;
PCCURC[ECB_FNI] = 0;
PCMSPN(.JFN);
HLFTMP[HLF_LFT] = .FORK;
HLFTMP[HLF_RGT] = .JFN;
BEGIN
REGISTER R1=1;
R1=.HLFTMP;
IF NOT MACHSKIP(%O'260',15,DOGET,0,0)
THEN
ERROR('Unable to get program')
END;
BEGIN
REGISTER R1=1;
R1 = CH$PTR(UPLIT(0));
JSYS(1,RSCAN,R1)
END;
SETINV(.FORK);
STAYF = 0;
END;
ROUTINE FNDCTY(AJFN,ANUM): NOVALUE = ! Get a PDS for PCL
!++
! Functional description:
! Get a PTY or a PDS for use as a fork controller or a DoCommand
! output handler; open it and set up the Exec to handle the
! interrupts. Return the JFN and PTY/PDS number in the caller's
! arguments.
!
! Formal parameters:
! Addresses of words in which to store JFN and device number
!
! Implicit inputs:
! None
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
%IF %VARIANT
%THEN
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
JFN, ! JFN
NUM; ! Device number
BEGIN
REGISTER R1=1,R2=2;
R1 = GJ_SHT;
R2 = BYTPTR(UPLIT (%ASCIZ 'PDS:'));
IF NOT JSYS(1,GTJFN,R1,R2) THEN R1=-1;
JFN = .R1
END;
IF .JFN GTR 0
THEN
BEGIN
IF
BEGIN
REGISTER R1=1,R2=2;
R1 = .JFN;
R2 = FLD(8,OF_BSZ) + OF_RD + OF_WR;
JSYS(1,OPENF,R1,R2)
END
THEN
BEGIN
BEGIN
REGISTER R1=1,R2;
R1 = .JFN;
R2 = $MOITY;
IF JSYS(-1,MTOPR,R1,R2) THEN NUM = .R2;
END;
IF .NUM NEQ 0
THEN
BEGIN
REGISTER R1=1,R2=2;
R1 = .JFN;
R2 = $MOAPI + MO_WFI + MO_OIR + FLD(PCLCHI,MO_SIC);
JSYS(-1,MTOPR,R1,R2);
.AJFN = .JFN;
.ANUM = .NUM
END;
RETURN
END
ELSE
BEGIN
REGISTER R1=1;
R1 = .JFN;
JSYS(1,RLJFN,R1)
END
END;
ERROR('Unable to obtain PDS')
END;
%ELSE
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
JFN, ! JFN
NUM, ! PTY number
R1T, ! Register temporaries
R2T,
FIRPTY, ! First PTY in system
SYSPTY, ! Number of PTY's in system
HLFTMP: HLF_WRD, ! Temporary
PTYNAM: VECTOR[10]; ! PTY name
BEGIN
REGISTER R1=1;
R1 = $PTYPA;
JSYS(1,GETAB,R1);
HLFTMP = .R1;
FIRPTY = .HLFTMP[HLF_RGT];
SYSPTY = .HLFTMP[HLF_LFT]
END;
INCR I TO .SYSPTY-1 DO
BEGIN
HLFTMP[HLF_LFT] = $DVDES + $DVPTY;
HLFTMP[HLF_RGT] = .I;
R1T = .HLFTMP;
BEGIN
REGISTER R1=1,R2=2;
R1 = .R1T;
JSYS(0,DVCHR,R1,R2);
R1T = .R1;
R2T = .R2
END;
IF .POINTR(R2T,DV_AV)
THEN
BEGIN
R2T = .R1T;
R1T = BYTPTR(PTYNAM);
IF
BEGIN
LOCAL VAL;
REGISTER R1=1,R2=2;
R1=.R1T;
R2=.R2T;
VAL = JSYS(1,DEVST,R1,R2);
R1T = .R1;
.VAL
END
THEN
BEGIN
CH$WCHAR_A(%C':',R1T);
CH$WCHAR_A(0,R1T);
BEGIN
REGISTER R1=1,R2=2;
R1 = GJ_SHT;
R2 = BYTPTR(PTYNAM);
IF NOT JSYS(1,GTJFN,R1,R2) THEN R1=-1;
JFN = .R1
END;
IF .JFN GTR 0
THEN
BEGIN
R1T = .JFN;
R2T = FLD(8,OF_BSZ) + OF_RD + OF_WR;
IF
BEGIN
REGISTER R1=1,R2=2;
R1=.R1T;
R2=.R2T;
JSYS(1,OPENF,R1,R2)
END
THEN
BEGIN
NUM = .I + .FIRPTY;
BEGIN
REGISTER R1=1;
R1 = $TTDES + .NUM;
JSYS(1,ASND,R1)
END;
.AJFN = .JFN;
.ANUM = .NUM;
BEGIN
REGISTER R1=1,R2=2;
R1 = .JFN;
R2 = $MOAPI + MO_WFI + MO_OIR + FLD(PCLCHI,MO_SIC);
JSYS(-1,MTOPR,R1,R2)
END;
RETURN
END
ELSE
BEGIN
REGISTER R1=1;
R1 = .JFN;
JSYS(1,RLJFN,R1)
END
END
END
END
END;
ERROR('Unable to obtain PTY')
END;
%FI
ROUTINE REDFRK(STRT): NOVALUE = ! Ready fork
!++
! Functional description:
! Set user program's controlling terminal and primary JFNs
! to PCL's PTY. As requested, either start fork running
! or continue it.
!
! Formal parameters:
! Nonzero to start fork running, zero to continue
!
! Implicit inputs:
! None
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
R1T, ! Register temporary
R2T,
DESIG, ! Designator
HLFTMP: HLF_WRD; ! Temporary
HLFTMP[HLF_LFT] = $SCSET;
HLFTMP[HLF_RGT] = .PCCURC[ECB_CFK];
DESIG = $TTDES + .PCCURC[ECB_CTN];
BEGIN
REGISTER R1=1,R2=2;
R1 = .HLFTMP;
R2 = .DESIG;
JSYS(-1,SCTTY,R1,R2)
END;
HLFTMP[HLF_LFT] = .DESIG;
HLFTMP[HLF_RGT] = .DESIG;
R2T = .HLFTMP;
R1T = .PCCURC[ECB_CFK];
IF NOT
BEGIN
REGISTER R1=1,R2=2;
R1=.R1T;
R2=.R2T;
JSYS(-1,SPJFN,R1,R2)
END
THEN
ERROR('Unable to SPJFN');
BEGIN
REGISTER
R1=1,R2=2;
R1 = $TTDES + .PCCURC[ECB_CTN];
JSYS(0,RFMOD,R1,R2);
POINTR(R2,TT_LIC) = 0;
POINTR(R2,TT_ECO) = 0;
POINTR(R2,TT_DUM) = $TTLDX;
JSYS(0,SFMOD,R1,R2);
JSYS(0,STPAR,R1,R2)
END;
IF .PCPOTP GTR 0
THEN
BEGIN
LOCAL
PTR: REF STB_BLK;
PTR = .PCPOTP;
RETMEM(.PTR[STB_LEN], .PTR, XDICT);
PCPOTP = 0
END;
IF .STRT NEQ 0
THEN
R1T = .PCCURC[ECB_CFK];
IF .STRT EQL 0 THEN R1T = .R1T + SF_CON;
R2T = 0;
IF NOT
BEGIN
REGISTER R1=1,R2=2;
R1=.R1T;
R2=.R2T;
JSYS(-1,(IF .STRT EQL 0 THEN SFORK ELSE SFRKV),R1,R2)
END
THEN
ERROR('Unable to start or continue fork')
END;
GLOBAL ROUTINE PCICLP(KILFRK): NOVALUE = ! Clean up all JFN's and forks
!++
! Functional description:
! Release all PTY/PDS's; read and forget any unread typeout;
! if a program is being controlled, reset fork to real terminal.
! Release all runtime Parse and I/O JFN's. If requested, kill
! the invoked fork.
!
! Formal parameters:
! Nonzero to kill invoked fork
!
! Implicit inputs:
! Current Execution Context Block
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
IF (.PCCURC[ECB_DTN] NEQ 0) OR (.PCCURC[ECB_CTN] NEQ 0)
THEN
BEGIN
PCIPSO();
IF .PCCURC[ECB_CTN] NEQ 0
THEN
BEGIN
REGISTER R1=1,R2=2;
LOCAL
HLFTMP: HLF_WRD;
R1 = .PCCURC[ECB_CTJ];
JSYS(1,CLOSF,R1);
HLFTMP[HLF_LFT] = $SCRST;
HLFTMP[HLF_RGT] = .PCCURC[ECB_CFK];
R1 = .HLFTMP;
JSYS(-1,SCTTY,R1,R2);
%IF NOT %VARIANT
%THEN
R1 = $TTDES + .PCCURC[ECB_CTN];
JSYS(1,RELD,R1);
%FI
R1 = $FHSLF;
JSYS(0,GPJFN,R1,R2);
R1 = .PCCURC[ECB_CFK];
JSYS(-1,SPJFN,R1,R2);
PCCURC[ECB_CTN] = 0;
PCCURC[ECB_CTJ] = 0
END;
IF .PCCURC[ECB_DTN] NEQ 0
THEN
BEGIN
REGISTER R1=1;
%IF NOT %VARIANT
%THEN
R1 = $TTDES + .PCCURC[ECB_DTN];
JSYS(1,RELD,R1);
%FI
R1 = .PCCURC[ECB_DTJ];
JSYS(1,CLOSF,R1);
PCCURC[ECB_DTN] = 0;
PCCURC[ECB_DTJ] = 0
END;
IF .PCPOTP GTR 0
THEN
BEGIN
LOCAL
PTR: REF STB_BLK;
PTR = .PCPOTP;
RETMEM(.PTR[STB_LEN], .PTR, XDICT);
PCPOTP = 0
END;
IF .PCPEOP GTR 0
THEN
BEGIN
LOCAL
PTR: REF STB_BLK;
PTR = .PCPEOP;
RETMEM(.PTR[STB_LEN], .PTR, XDICT);
PCPEOP = 0
END
END;
PCIRPL();
DINCLS(0,0);
IF .KILFRK NEQ 0 AND .PCCURC[ECB_CFK] NEQ 0 THEN PCIKIF();
PCCURC[ECB_CFK] = 0
END;
GLOBAL ROUTINE PCIKIF: NOVALUE = ! Kill invoked fork
!++
! Functional description:
! Kill the controlled fork (unless it was not Invoked)
! and do away with its PTY.
!
! Formal parameters:
! None
!
! Implicit inputs:
! ECB_CFK
!
! Implicit outputs:
! FORK
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
IF .PCCURC[ECB_CFK] NEQ 0
THEN
BEGIN
EXTERNAL REGISTER Z=0;
IF .PCCURC[ECB_CTN] NEQ 0
THEN
BEGIN
PCIPSO();
BEGIN
REGISTER R1=1,R2=2;
LOCAL HLFTMP: HLF_WRD;
R1 = .PCCURC[ECB_CTJ];
JSYS(1,CLOSF,R1);
HLFTMP[HLF_LFT] = $SCRST;
HLFTMP[HLF_RGT] = .PCCURC[ECB_CFK];
R1 = .HLFTMP;
JSYS(-1,SCTTY,R1);
%IF NOT %VARIANT
%THEN
R1 = $TTDES + .PCCURC[ECB_CTN];
JSYS(1,RELD,R1);
%FI
R1 = $FHSLF;
JSYS(0,GPJFN,R1,R2);
R1 = .PCCURC[ECB_CFK];
JSYS(-1,SPJFN,R1,R2)
END;
PCCURC[ECB_CTN] = 0;
PCCURC[ECB_CTJ] = 0
END;
IF .PCPOTP GTR 0
THEN
BEGIN
LOCAL
PTR: REF STB_BLK;
PTR = .PCPOTP;
RETMEM(.PTR[STB_LEN], .PTR, XDICT);
PCPOTP = 0
END;
IF .PCCURC[ECB_FNI] EQL 0 THEN KEFORK(.PCCURC[ECB_CFK]);
PCCURC[ECB_CFK] = 0
END;
GLOBAL ROUTINE PCIRPL: NOVALUE = ! Release Parse JFN list
!++
! Functional description:
! Release all the parsed JFNs and the list itself.
!
! Formal parameters:
! Parsed JFN list
!
! Implicit inputs:
! None
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
IF .PCCURC[ECB_PFL] NEQ 0
THEN
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
OLST: REF JLS_WRD, ! List pointers
NLST: REF JLS_WRD;
OLST = .PCCURC[ECB_PFL];
WHILE
.OLST NEQ 0
DO
BEGIN
NLST = .OLST[JLS_LNK];
BEGIN
REGISTER
R1=1;
R1 = .OLST[JLS_JFN];
JSYS(1,RLJFN,R1)
END;
RETMEM(2, .OLST, XDICT);
OLST = .NLST
END;
PCCURC[ECB_PFL] = 0
END;
GLOBAL ROUTINE PCITIN(PTR,CNT): NOVALUE = ! Type in to user program
!++
! Functional description:
! Pass provided string to user program, which should be running but
! blocked waiting for input. Once the program receives the input,
! it should continue processing; I wait for the program to either
! halt or require more terminal input. It may be that I am asked
! to type down more than the buffer will accept; in that case I
! write as much as possible, let the program run, and repeat.
!
! Formal parameters:
! Pointer to string to input
! Character count of string
!
! Implicit inputs:
! None
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
PT, ! Pointer
CT; ! Count
IF .PCCURC[ECB_CFK] EQL 0
THEN
BEGIN
IF .FORK LEQ 0 THEN ERROR('No fork available for typein');
PCCURC[ECB_CFK] = .FORK;
PCCURC[ECB_FNI] = 1;
IF .PCCURC[ECB_CTN] EQL 0
THEN
BEGIN
LOCAL
JFN, ! JFN on PDS
NUM; ! Number of PDS
FNDCTY(JFN,NUM);
PCCURC[ECB_CTN] = .NUM;
PCCURC[ECB_CTJ] = .JFN
END;
REDFRK(0)
END;
PT = .PTR;
CT = -.CNT;
PCFORK = .FORK; ! Save old value of FORK
PCRNFK = .RUNFK; ! and RUNFK
IF .PCCURC[ECB_CFK] NEQ 0
THEN
BEGIN
FORK = .PCCURC[ECB_CFK];
RUNFK = .PCCURC[ECB_CFK];
END;
DO
BEGIN
BEGIN
REGISTER
R1=1,R2=2,R3=3;
R1 = .PCCURC[ECB_CTJ];
R2 = .PT;
R3 = .CT;
JSYS(-1,SOUT,R1,R2,R3);
PT = .R2;
CT = .R3
END;
WTFPGM()
END
UNTIL
.CT EQL 0;
FORK = .PCFORK;
RUNFK = .PCRNFK;
PCFORK = -2;
PCRNFK = -2;
END;
ROUTINE WTFPGM = ! Wait for program to require PCL
!++
! Functional description:
! Continue user program, and wait for it to either halt, die,
! or read from its controlling PTY/PDS.
!
! Formal parameters:
! None
!
! Implicit inputs:
! None
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
PCPRGR = -1;
PCMWTF();
! Be aware that if the fork gets an error EXECP will issue an ERROR
PCPRGR = 0
END;
GLOBAL ROUTINE PCIPEO: NOVALUE = ! Prepare for Exec output
!++
! Functional description:
! Make sure PCL has a PDS for DoCommand output, initialize an
! output buffer, so the PTY reader knows where to put the output.
! Keeps information on this PDS in ECB.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Current Execution Context Block
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
PTR: REF STB_BLK, ! String block
JFN, ! JFN on PDS
NUM; ! Number of PDS
IF .PCCURC[ECB_DTN] NEQ 0 THEN RETURN;
FNDCTY(JFN,NUM);
PCCURC[ECB_DTN] = .NUM;
PCCURC[ECB_DTJ] = .JFN;
PTR = PCMGMM(10, XDICT);
PTR[STB_CNT] = 0;
PTR[STB_LEN] = 10;
PCPEOP = .PTR
END;
GLOBAL ROUTINE PCIPSO: NOVALUE = ! Handle controller pseudointerrupt
!++
! Functional description:
! Entered when PTY/PDS-output PSI occurs. Reads all pending output
! from the PDS's and saves them in their standard string blocks.
!
! Formal parameters:
! None
!
! Implicit inputs:
! PTY/PDS, current Execution Context Block
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! Disables interrupts while running
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
CNT, ! Character count
TBL, ! Address of block pointer being updated
PECB: REF ECB_BLK, ! ECB doing DoCommand To
PTR: REF STB_BLK; ! Output buffer pointer
BEGIN
REGISTER R1=1;
R1 = $FHSLF;
JSYS(0,DIR,R1)
END;
PECB = .PCCURC;
WHILE
.PECB NEQ 0 AND .PECB[ECB_DTO] EQL %O'777777'
DO
PECB = .PECB[ECB_NXT];
DECR I FROM (IF .PECB NEQ 0 THEN 1 ELSE 0) DO
BEGIN
WHILE
BEGIN
REGISTER R1=1,R2=2;
IF .I NEQ 0
THEN
R1 = $TTDES + .PECB[ECB_DTN]
ELSE
R1 = $TTDES + .PCCURC[ECB_CTN];
IF JSYS(1,SOBE,R1,R2) THEN R2 = 0;
CNT = .R2
END
NEQ 0
DO
BEGIN
TBL = (IF .I NEQ 0 THEN PCPEOP ELSE PCPOTP);
PTR = ..TBL;
IF .PTR EQL 0
THEN
BEGIN
PTR = PCMGME( (.CNT+100)/5, XDICT);
IF .PTR NEQ 0
THEN
BEGIN
PTR[STB_CNT] = 0;
PTR[STB_LEN] = (.CNT+100)/5
END
ELSE
PTR = -1;
.TBL = .PTR;
END
ELSE
IF .PTR GTR 0
THEN
BEGIN
IF (.PTR[STB_LEN]-1)*5-.PTR[STB_CNT] LSS .CNT
THEN
BEGIN
LOCAL
NEW: REF STB_BLK;
NEW = PCMGME( (.PTR[STB_CNT]+.CNT+100)/5, XDICT);
IF .NEW NEQ 0
THEN
BEGIN
NEW[STB_LEN] = (.PTR[STB_CNT]+.CNT+100)/5;
NEW[STB_CNT] = .PTR[STB_CNT];
CH$MOVE(.PTR[STB_CNT], BYTPTR(PTR[STB_BUF]),
BYTPTR(NEW[STB_BUF]))
END
ELSE
NEW = -1;
RETMEM(.PTR[STB_LEN], .PTR, XDICT);
.TBL = .NEW;
PTR = .NEW
END
END;
BEGIN
REGISTER
R1=1,R2=2,R3=3;
R1 = (IF .I NEQ 0 THEN .PECB[ECB_DTJ] ELSE .PCCURC[ECB_CTJ]);
IF .PTR GTR 0
THEN
R2 = CH$PTR(PTR[STB_BUF],.PTR[STB_CNT])
ELSE
R2 = $NULIO;
R3 = - .CNT;
JSYS(0,SIN,R1,R2,R3);
IF .PTR GTR 0 THEN PTR[STB_CNT] = .PTR[STB_CNT] + .CNT
END;
IF .PCCURC[ECB_PAS] AND .PCPOTP NEQ 0
THEN
BEGIN
PTR = .PCPOTP;
PCPOTP = 0;
BEGIN
REGISTER R1=1,R2=2,R3=3;
R1 = .COJFN;
R2 = BYTPTR(PTR[STB_BUF]);
R3 = -.PTR[STB_CNT];
JSYS(0,SOUT,R1,R2,R3)
END;
RETMEM(.PTR[STB_LEN], .PTR, XDICT)
END
END
END;
BEGIN
REGISTER R1=1;
R1 = $FHSLF;
JSYS(0,EIR,R1)
END
END;
GLOBAL ROUTINE PCIDPY(ADR,LEN,FLG,TYP): NOVALUE = ! Display on real terminal
!++
! Functional description:
! Prints string or integer on real terminal.
!
! Formal parameters:
! Integer or address of string to display
! Length of string (currently ignored for integers)
! Flag: 0=Normal, 1=Binary, -1=Normal without CRLF
! Type of value being displayed: GST_TYP_INT or GST_TYP_STR
!
! Implicit inputs:
! None
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
SAVMODE;
REGISTER R1=1,R2=2,R3=3;
R1 = .COJFN;
IF .FLG GTR 0
THEN
BEGIN
JSYS(0,RFMOD,R1,R2);
SAVMODE = .R2;
POINTR(R2,TT_DAM) = 0;
JSYS(0,SFMOD,R1,R2)
END;
IF .TYP EQL GST_TYP_STR
THEN ! String
BEGIN
R2 = BYTPTR(.ADR);
R3 = .LEN;
JSYS(0,SOUT,R1,R2,R3)
END
ELSE ! Integer
BEGIN
R2 = .ADR;
R3 = FLD(10,NO_RDX);
JSYS(-1,NOUT,R1,R2,R3);
END;
IF .FLG EQL 0
THEN
BEGIN
R2 = CH$PTR(UPLIT(%CHAR($CHCRT,$CHLFD)));
R3 = -2;
JSYS(0,SOUT,R1,R2,R3)
END;
IF .FLG GTR 0
THEN
BEGIN
R2 = .SAVMODE;
JSYS(0,SFMOD,R1,R2)
END;
BEGIN
JSYS(0,RFPOS,R1,R2);
PCCURC[ECB_POS] = .R2
END
END;
END
ELUDOM