.title SETUP - Set up VMS working environment
.ident "V4.0"
; .library /mar:always/
;
; Program: SETUP.MAR V4.0, VAX/VMS V5.1-1
;
; Author: David G. North, CCP
; 1333 Maywood Ct
; Plano, Texas 75023
; (214) 653-1231
; Additional
; Routines: Hunter Goatley - DCL key definition routines,
; original article February 1988 issue of
; Vax Professional
;
; Date: 90.11.20
;
; Revisions:
; Who Date Description
; D.North 901120 DECUS release
;
; License:
; Ownership of and rights to these programs is retained by the author(s).
; Limited license to use and distrubute the software in this library is
; hereby granted under the following conditions:
; 1. Any and all authorship, ownership, copyright or licensing
; information is preserved within any source copies at all times.
; 2. Under absolutely *NO* circumstances may any of this code be used
; in any form for commercial profit without a written licensing
; agreement from the author(s). This does not imply that such
; a written agreement could not be obtained.
; 3. Except by written agreement under condition 2, source shall
; be freely provided with all executables.
; 4. Library contents may be transferred or copied in any form so
; long as conditions 1, 2, and 3 are met. Nominal charges may
; be assessed for media and transferral labor without such charges
; being considered 'commercial profit' thereby violating condition 2.
;
; Warranty:
; These programs are distributed in the hopes that they will be useful, but
; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
; or FITNESS FOR A PARTICULAR PURPOSE.
;
; Description: See accompanying SETUP.RNO.
; The symbols MODE, $MODE, QUEUE_NAME, and ENTRY_NUMBER are
; defined for use by subsequent images or DCL.
;
; Revisions: When What
; 88.07.01 - Added Priority Boost and /NOSWAP
; 88.07.12 - Added rundown timer in case of program error
; 89.02.13 - Add DCL key definition routines (Goatley)
; 89.07.11 - Added REPLY/ENABLE capability
; 89.07.12 - Added SET MESSAGE capability (disabled)
; 89.07.12 - Added DISABLE_CMKRNL & DISABLE_CMEXEC
; 89.07.14 - Added unique macro library for SETUP (SETUPMLB)
; 89.07.14 - Added code for node specific items
; 89.07.17 - Changed error messages to use $PUTMSG service
; 90.11.19 - Cleaned up 'getopt_' test types & documentation
; 90.11.20 - Prompt, verify, exit command, internal restructure
;
.library "setupmlb"
.link "sys$system:sys.stb"/selective_search
.link "sys$system:dcldef.stb"/selective_search
$brkdef
$chfdef
$dvidef
$iodef
$jpidef
$lnmdef
$opcdef
$prvdef
$psldef
$quidef
$ssdef
$ttdef
$tt2def
$uaidef
_msgbitdef
_prtdef
_nodedef
.PSECT $USRDATA,NOEXE,RD,WRT
; __ Customization section begins __
; __ Customization section begins __
; __ Customization section begins __
;
;*** This program is designed to boost itself while running... uncomment
; the following to disable generation of boosting code
;DISABLE_BOOST = 1 ; comment this to enable boosting code
;
;*** This program can set the message flags for the process... unfortunately,
; they are protected URKW necessitating use of KERNEL mode code to set them.
; Since this may be unacceptable in a production environment, you must
; comment out the following line of code in order to allow generation of
; the $CMKRNL calls. Note that this is node-dependent and therefore may
; be enabled on a per-node basis... the DISABLE_CMKRNL flag is used to
; prevent *ANY* usage of kernel code for *ALL* nodes.
;DISABLE_CMKRNL = 1 ; comment to enable KERNEL code
;
;*** Similar flag for EXECUTIVE code (DCL keys)
;DISABLE_CMEXEC = 1 ; comment to enable EXEC code
;
;*** Similar flag for SUPERVISOR code (DCL prompt & verify) (via EXEC)
;DISABLE_CMSUPER = 1 ; comment to enable SUPERVISOR code
;
;*
;*** This is the lists of known nodes and classes
; Privilege classes
DEFINE_CLASS CMSUPER ; May use supervisor code if generated
DEFINE_CLASS CMEXEC ; May use exec code if generated
DEFINE_CLASS CMKRNL ; May use kernel code if generated
; Operator/privilege classes
DEFINE_CLASS OPER1 ; May enable self as operator (reply set 1)
DEFINE_CLASS OPER2 ; May enable self as operator (reply set 2)
; Node/Cluster classes
DEFINE_CLASS DWARVES ; Member of DWARVES cluster
DEFINE_CLASS GIANTS ; Member of GIANTS cluster
DEFINE_CLASS OTHER ; Member of OTHER cluster or NO cluster
; AltSyslib class - uses [1,3] instead of [1,2]...
DEFINE_CLASS ALTSYSLIB ; Use alternate syslib (protection for PRD1-4)
DEFINE_CLASS HOMEBASE ; Node is a home base... full environment
; Collection definitions
DEFINE_COLLECTION PRIV_NODE,CMKRNL,CMEXEC,CMSUPER
DEFINE_COLLECTION ALL_NODES,GIANTS,DWARVES,OTHER
DEFINE_COLLECTION NON_GIANT,DWARVES,OTHER
DEFINE_COLLECTION PRODUCTION,DWARVES,CMEXEC,CMSUPER,OPER1,ALTSYSLIB
; Node definitions
DEFINE_NODE DEVEL,DWARVES,PRIV_NODE,HOMEBASE,,OPER1
DEFINE_NODE PRD1,PRODUCTION
DEFINE_NODE PRD2,PRODUCTION
DEFINE_NODE PRD3,PRODUCTION
DEFINE_NODE PRD4,PRODUCTION
DEFINE_NODE GIANT1,GIANTS
DEFINE_NODE GIANT2,GIANTS
DEFINE_NODE GIANT3,GIANTS
DEFINE_NODE TSTBED,OTHER,PRIV_NODE,OPER2
;*
;*** This list of symbols will be categorcally atomized with no errors
; (Usage is default...only class-mismatch not executed)
hitlst:
.ITM <CLEAR>
.ITM <CLR>
.ITM <ERROR>
.ITM <MTEXCH>
.ITM <WHO>
.EOLIST
;*
;*** This is the list of symbols to be defined
; (Usage is default...only class-mismatch not executed)
symlst:
.ITMVAL <ALLBRO>,<set bro=all>
.ITMVAL <AUTH*ORIZE>,<$authorize>
.ITMVAL <BRO>,<set te/bro>
.ITMVAL <CD>,<$$:cd.exe>
.ITMVAL <CDF_M$>,<dsk:[private.work.mar.!16(AS)]>
.ITMVAL <CDI_M>,<dsk:[private.work.mar]>
.ITMVAL <CRA*SH>,<anal/cra>
.ITMVAL <DATE>,<wr sys$output f$ext(0,11,f$time())>
.ITMVAL <DAY>,<wr sys$output f$cvtime(f$time(),"absolute","weekday")>
.ITMVAL <DOFF>,<@tools:debugoff>
.ITMVAL <DON>,<@tools:debugon>
.ITMVAL <E*DIT>,<ed/tpu>
.ITMVAL <MA*IL>,<mail/edit>
.ITMVAL <MY*TABLES>,<set com/tab=$:dcltables>
.ITMVAL <NICE>,<set proc/prio=3>
.ITMVAL <NOBRO>,<set te/nobro>
.ITMVAL <NONICE>,<set proc/prio=4>
.ITMVAL <NOVER>,<set nover>
.ITMVAL <PH*ONE>,<phone/swit="§">
.ITMVAL <PRV>,<$$:prv>
.ITMVAL <SDA>,<@tools:keptsda>
.ITMVAL <SYST*ABLES>,<set com/tab=sys$share:dcltables>
.ITMVAL <TI*ME>,<wr sys$output f$ext(12,11,f$time())>
.ITMVAL <TRUE>,<1>
.ITMVAL <VER>,<set verify>
.EOLIST
;*
;*** This is the list of logicals to be defined
;*** Note use of table names and how attributes are specified
; (Usage is default...only class-mismatch not executed)
loglst: .ITM <LNM$JOB>
.ITMVAL <$>,<DSK:[1,2]>
.ITMVAL <$>,<DSK:[1,3]>,COLL=ALTSYSLIB
.ITMVAL <DSK>,<*>,OPTION=LNM$M_CONCEALED
.ITMVAL <HERE>,<SYS$DISK:[]>
.ITMVAL <MAIL$EDIT>,<CALLABLE_TPU>
.ITMVAL <MAR>,<DSK:[PRIVATE.WORK.MAR]>
.ITMVAL <PREV>,<LAST_DEFAULT_DIRECTORY>
.ITMVAL <ROOT>,<DSK:[000000]>
.ITMVAL <SYS$LOGIN>,<DSK:[000000]>
.ITMVAL <SYS$LOGIN_DEVICE>,<DSK:>
.ITMVAL <SYS$SCRATCH>,<DSK:[1,1]>
.ITMVAL <RCVVSM>,<$2$DUA233:>,-
OPTION=<LNM$M_CONCEALED>,COLL=DWARVES
.EOLIST
.EOLIST
;*
;*** This is the list of keys to be defined
;*** Note use of IFSTATE names and how attributes are specified
; (Usage is default...only class-mismatch not executed)
; (Note though, that 'keycls' collection {exact} membership req'd first!)
keycls: .COLL CMEXEC
keylst: .ITM <DEFAULT>
.ITMVAL <HELP>,<he>,-
OPTION=<SYM_M_TERMINATE!SYM_M_ERASE>
.ITMVAL <DO>,<dir>,-
OPTION=<SYM_M_TERMINATE!SYM_M_ERASE>
.ITMVAL <PF1>,<set te/wi=80>,-
OPTION=<SYM_M_TERMINATE!SYM_M_ERASE>
.ITMVAL <PF4>,<sh u>,-
OPTION=<SYM_M_TERMINATE!SYM_M_ERASE>
.ITMVAL <F20>,<ki>,-
OPTION=<SYM_M_TERMINATE!SYM_M_ERASE>
.ITMVAL <E2>,<cd>,-
OPTION=<SYM_M_TERMINATE!SYM_M_ERASE!SYM_M_ECHO>
.ITMVAL <E5>,<cd $>,-
OPTION=<SYM_M_TERMINATE!SYM_M_ERASE!SYM_M_ECHO>
.ITMVAL <E6>,<cd #>,-
OPTION=<SYM_M_TERMINATE!SYM_M_ERASE!SYM_M_ECHO>
.EOLIST
.EOLIST
;*
;*** This is the list of processnames to be attempted 'til success
; (Usage is inhibited...class membership, or null<-->null match req'd)
stdprc: .ITM <Try $ STO/I=0>
.ITM <Have a day>
.ITM <Phantom>
.ITM <C.U.L8TR>
.ITM <Ctmytitym>
.ITM <Ttstkwtmrd>
.ITM <Buzz off>
.ITM <Wizard>
.EOLIST ;Essentially not used...comment
prclst: .ITM OPTION=stdprc
.ITM OPTION=stdprc,COLL=ALL_NODES
.EOLIST
;*
;*** This is the list of prompts
; (Usage is protected...class membership must exist)
; Items in the prompt list will be activated if *all* characteristics are
; matched. The first match of all characteristics will terminate the
; operation.
wizset: .ascid <^x90>"1;16;1;0;0;2;0;0;{1???????????????/????????___ow}~//;"-
<^x9c><^x90>"1;17;1;0;0;2;0;0;{1G[{{G_oPxwGa~d~/???@@HKNw~kNNNN//;"-
<^x9c><^x90>"1;24;1;0;0;2;0;0;{1???????????????/lxba_o??????_{[//;"-
<^x9c><^x90>"1;25;1;0;0;2;0;0;{1|NzyWWWKKKCs~N?/N}xnKG???o{NB??//;"-
<^x9c>
wizprm: .ascid <^x1b>"[1m"<^x1b>")1"<^x0e>"08"<^x1b>"[2D"<^x0a>"19"-
<^x1b>")1"<^x0f><^x1b>"[m "
dotprm: .ascid <^x1b>"[1m«»"<^x1b>"[m"
stprmv: .address dotprm
.long 0 ;no setup
.long TT$_VT300_SERIES,0,TT2$M_REGIS
.address wizprm
.address wizset
.long TT$_VT300_SERIES,0,0
.EOLIST
prmlst: .ITM OPTION=stprmv,COLL=CMSUPER
.EOLIST
;*
;*** This is the SET VERIFY flag
; (Usage is protected...class membership must exist)
othver:
batver:
netver:
falver:
intver: .ITM OPTION=0,COLL=CMSUPER
.EOLIST
;*
;*** This is the default protection
; (Usage is inhibited...class membership, or null<-->null match req'd)
defpro: .ITM OPTION=<<PRT_M_RE @PRT_V_SYSTEM>!<PRT_M_RWED @PRT_V_OWNER>!-
<PRT_M_N @PRT_V_GROUP> !<PRT_M_N @PRT_V_WORLD>>
.ITM OPTION=<<PRT_M_RE @PRT_V_SYSTEM>!<PRT_M_RWED @PRT_V_OWNER>!-
<PRT_M_N @PRT_V_GROUP> !<PRT_M_N @PRT_V_WORLD>>,-
COLL=ALL_NODES
.EOLIST
;*
;*** This is the default message flags
.IF NDF,DISABLE_CMKRNL
; (Usage is inhibited...class membership, or null<-->null match req'd)
; (Note though, that 'msfcls' collection {exact} membership req'd first!)
msfcls: .COLL CMKRNL
defmsg: .ITM OPTION=MSGBIT_M_TEXT,COLL=CMKRNL
.EOLIST
.ENDC
;*
;*** These are the default privilege masks for the process
; (Usage is inhibited...class membership, or null<-->null match req'd)
; -- Default masks available...define new privilege combinations here
stdmsk: .long <PRV$M_TMPMBX!PRV$M_NETMBX!PRV$M_SETPRV>,<1@<PRV$V_READALL-32>>
minmsk: .long <PRV$M_TMPMBX!PRV$M_NETMBX>,0
netmsk: .long <PRV$M_TMPMBX!PRV$M_NETMBX!PRV$M_SETPRV!PRV$M_EXQUOTA!PRV$M_BYPASS>,0
allmsk: .long -1,-1
; -- Mask lists by mode by classes...define new classes here to access masks
batprv:
othprv:
intprv: .ITM OPTION=stdmsk
.ITM OPTION=allmsk,COLL=NON_GIANT
.ITM OPTION=minmsk,COLL=GIANTS
.EOLIST
falprv: .ITM OPTION=minmsk
.ITM OPTION=minmsk,COLL=ALL_NODES
.EOLIST
netprv: .ITM OPTION=netmsk
.ITM OPTION=netmsk,COLL=ALL_NODES
.EOLIST
;*
;*** These define default directories by mode by node
; (Usage is inhibited...class membership, or null<-->null match req'd)
; -- Default dirs available...define new default dirs here
dirpw: .ascid /[PRIVATE.WORK]/
dirpn: .ascid /[PRIVATE.NETWORK]/
; -- Dir lists by mode by classes...define new classes here to access dirs
faldir: ; failure
batdir: ; batch
othdir: ; other
intdir: ; interactive
.ITM OPTION=dirpw
.ITM OPTION=dirpw,COLL=ALL_NODES
.EOLIST
netdir: ; network
.ITM OPTION=dirpn
.ITM OPTION=dirpn,COLL=ALL_NODES
.EOLIST
;
;*** These define matching default drives by mode
; (Usage is inhibited...class membership, or null<-->null match req'd)
; -- Default drives available...define new default drives here
drvpw:
drvpn: .ascid /DSK:/
; -- Drive lists by mode by classes...define new classes here to access drives
faldrv: ; failure
batdrv: ; batch
othdrv: ; other
intdrv: ; interactive
netdrv: ; network
.ITM OPTION=drvpn
.ITM OPTION=drvpn,COLL=ALL_NODES
.EOLIST
;
;*** This defines terminal broadcast states by node
; (Usage is inhibited...class membership, or null<-->null match req'd)
; -- Broadcast states available...define new broadcast states here
stdbro: .long 0,<1@<BRK$C_USER1-32>>!<1@<BRK$C_USER15-32>>!-
<1@<BRK$C_USER16-32>>
; -- Broadcast states by classes...define new classes here for broadcast states
ttbro: .ITM OPTION=stdbro
.ITM OPTION=stdbro,COLL=ALL_NODES
.EOLIST
;
;*** These define terminal characteristics by node
; (Usage is inhibited...class membership, or null<-->null match req'd)
stdoff: .byte 0 ;class
.byte 0 ;type
.word 0 ;width
.long TT$M_NOBRDCST!<0@24> ;0@24 is the page length position
.long TT2$M_INSERT ;extended chars
stdon: .long 0,0,0 ;same structure as above
; -- Broadcast states by classes...define new classes here for broadcast states
ttoff: .ITM OPTION=stdoff
.ITM OPTION=stdoff,COLL=ALL_NODES
.EOLIST
tton: .ITM OPTION=stdon
.ITM OPTION=stdon,COLL=ALL_NODES
.EOLIST
;*
;*** This is the list of exit DCL commands
; (Usage is protected...class membership must exist)
stddo: .ascid /mytables/
; -- Dir lists by mode by classes...define new classes here to access dirs
batdo: ; batch
intdo: ; interactive
.ITM OPTION=stddo,COLL=ALL_NODES
.EOLIST
faldo: ; failure
othdo: ; other
netdo: ; network
.EOLIST
;
;*** This defines the default classes for which the terminal will be enabled
; as an operator to receive messages from OPCOM
; (Usage is protected...node must be member of collection)
opcmsk: .ITM COLL=OPER1,OPTION=<-
OPC$M_NM_CENTRL!-
OPC$M_NM_PRINT!-
OPC$M_NM_TAPES!-
OPC$M_NM_DISKS!-
OPC$M_NM_DEVICE!-
OPC$M_NM_CARDS!-
OPC$M_NM_CLUSTER!-
OPC$M_NM_SECURITY!-
OPC$M_NM_LICENSE!-
OPC$M_NM_OPER8!-
OPC$M_NM_OPER12>
.ITM COLL=OPER2,OPTION=<-
OPC$M_NM_CENTRL!-
OPC$M_NM_PRINT!-
OPC$M_NM_TAPES!-
OPC$M_NM_DISKS!-
OPC$M_NM_DEVICE!-
OPC$M_NM_CARDS!-
OPC$M_NM_NTWORK!-
OPC$M_NM_CLUSTER!-
OPC$M_NM_SECURITY!-
OPC$M_NM_LICENSE!-
OPC$M_NM_OPER1!-
OPC$M_NM_OPER2!-
OPC$M_NM_OPER3!-
OPC$M_NM_OPER4!-
OPC$M_NM_OPER5!-
OPC$M_NM_OPER6!-
OPC$M_NM_OPER7!-
OPC$M_NM_OPER8!-
OPC$M_NM_OPER9!-
OPC$M_NM_OPER10!-
OPC$M_NM_OPER11!-
OPC$M_NM_OPER12>
.EOLIST
;
; __ No Customization modifications below this point __
; __ No Customization modifications below this point __
; __ No Customization modifications below this point __
.PSECT $SETUPDATA,NOEXE,RD,WRT
;
;*** Annunciate status of code generation
.IIF NDF,DISABLE_CMKRNL, .PRINT 999 ; KERNEL code [7menabled[0m
.IIF DF,DISABLE_CMKRNL, .PRINT 999 ; KERNEL code disabled
.IIF NDF,DISABLE_CMEXEC, .PRINT 998 ; EXEC code [7menabled[0m
.IIF DF,DISABLE_CMEXEC, .PRINT 998 ; EXEC code disabled
.IIF NDF,DISABLE_CMSUPER, .PRINT 997 ; SUPERVISOR code [7menabled[0m
.IIF DF,DISABLE_CMSUPER, .PRINT 997 ; SUPERVISOR code disabled
.IIF NDF,DISABLE_BOOST, .PRINT 996 ; BOOST code [7menabled[0m
.IIF DF,DISABLE_BOOST, .PRINT 996 ; BOOST code disabled
;
;*** These are internal work vars and constants
extblk: .long 0,timout,1,extcnd ;exit handler description block
extcnd: .long 0 ;place for exit handler condition code
actprv: .quad 0 ;place to load active privs
modepr: .long othprv,netprv,batprv,intprv,falprv
actdrv: .long 0 ;place to load active drive
actdir: .long 0 ;place to load active dir
modecd: .long othdrv,othdir,netdrv,netdir,batdrv
.long batdir,intdrv,intdir,faldrv,faldir
modedo: .long othdo,netdo,batdo,intdo,faldo
modevf: .long othver,netver,batver,intver,falver
actbro: .long 0 ;address of active broadcast classes
actoff: .long 0 ;address of terminal *OFF* chars
acton: .long 0 ;address of terminal *ON* chars
actprc: .long 0 ;address of active processname list
actprm: .long 0 ;DCL prompt address
verify: .long 0 ;contents: verify state +1
actdo: .long 0 ;address if LIB$DO command
asctim: .ascid /0 0:0:5/ ;5s max boosted time
bintim: .quad
prctbl: .ascid /LNM$PROCESS_TABLE/
sysdsk: .ascid /SYS$DISK/
tblind: .long 2 ;annunciation to global table
offmsk: .long -1 ;mask to ashcan all privileges
.long -1
star: .asciz /*/
data1: .udesc 128
nodes: .ascid /NODE/
modes: .ascid /MODE/
mode0: .ascid /OTHER/
mode1: .ascid /NETWORK/
mode2: .ascid /BATCH/
mode3: .ascid /INTERACTIVE/
mode4: .ascid /JPI$_FAIL/
model: .long mode0
.long mode1
.long mode2
.long mode3
.long mode4
modev: .long 4
moden: .ascid /$MODE/
numctl: .ascid /%X!XL/
modval: .udesc 16
qnmsym: .ascid /QUEUE_NAME/
entsym: .ascid /ENTRY_NUMBER/
time: .blkl 2
cmeprv: .long <PRV$M_CMEXEC>,0
cmkprv: .long <PRV$M_CMKRNL>,0
booprv: .long <PRV$M_PSWAPM!PRV$M_SETPRI>,0
boopri = 12 ; boosted priority
norpri: .long 4 ; back down to normal
usrnam: .udesc 32
usrlen: .long 32 ; for restore if needed
uic: .long 0
jpilst: .long JPI$_MODE@16!4,modev,0
.long JPI$_AUTHPRI@16!4,norpri,0
.long JPI$_USERNAME@16!12,usrnam+8,usrnam
.long JPI$_UIC@16!4,uic,0
.long 0
defdev: .blkb 16
defdir: .blkb 64
uailst: .long UAI$_DEFDEV@16!16,defdev,0
.long UAI$_DEFDIR@16!64,defdir,0
.long 0
quflgs: .long QUI$M_SEARCH_THIS_JOB
entno: .long 0
entval: .udesc 16
quenam: .udesc 32
quiosb: .long 0,0 ;status
quilst: .long QUI$_SEARCH_FLAGS@16!4,quflgs,0
.long QUI$_ENTRY_NUMBER@16!4,entno,0
.long 0
quils2: .long QUI$_SEARCH_FLAGS@16!4,quflgs,0
.long QUI$_SEARCH_NAME@16!1,star,0
.long QUI$_QUEUE_NAME@16!31,quenam+8,quenam
.long 0 ; end of list
lnmfdv: .ascid /LNM$FILE_DEV/
lnmjob: .ascid /LNM$JOB/
syslgi: .ascid /SYS$LOGIN/
atr: .long 0
trn: .udesc
trnls1: .long LNM$_STRING@16!128,trn+8,trn,0
.long LNM$_ATTRIBUTES@16!4,atr,0
.long 0
curdir: .udesc
device: .udesc
exacmo: .byte PSL$C_EXEC
ttchr: .blkb 12
ttchn: .long 0
ttnam: .ascid /TT:/
;
enbmsg: .byte OPC$_RQ_TERME,1,0,0
enbcls: .long 0
unit: .word 0
devnml: .byte 0
devnam: .blkb 64
enbdsc: .long <^x010e0000!<.-enbmsg-64>>
.long enbmsg
retlen: .long 0
retunt: .long 0
oprprv: .long PRV$M_OPER,0
secprv: .long 0,<1@<PRV$V_SECURITY-32>>
dvilst: .long DVI$_FULLDEVNAM@16!64,devnam,retlen
.long DVI$_UNIT@16!4,retunt,0
.long 0
node: .long 0 ;no located nodename
class: .long 0 ;default class of none
nodeid: .udesc <^x20>
syilst: .long <SYI$_NODENAME@16>!15,nodeid+8,nodeid
.long 0
trnls2: .long LNM$_STRING@16!^x20,nodeid+8,nodeid,0
.long 0
sysnod: .ascid /SYS$NODE/
lnmsys: .ascid /LNM$SYSTEM/
;
.PSECT $SETUPCODE,PIC,USR,CON,REL,LCL,SHR,EXE,RD,NOWRT,NOVEC
;
;++
; ** OOPS_CATCHER - exception handler
;--
.entry oops_catcher, ^m<r4,r5>
movpsl r0
extzv #PSL$V_CURMOD,#PSL$S_CURMOD,r0,r0 ;get current mode
cmpl r0,#PSL$C_USER ; is it user mode???
bneq 10$ ; no...handle condition
calls #0,timout ; shut things up right
movl #SS$_RESIGNAL,r0 ; and pass it along....
brb 20$ ; normal return
10$: movl CHF$L_SIGARGLST(AP),r4 ; signal argument list
cmpl CHF$L_SIG_NAME(r4),#SS$_UNWIND ; is this an unwind???
beql 20$ ; yep... keep on unwinding
movl CHF$L_MCHARGLST(AP),r5 ; get mechanism list address
movl CHF$L_SIG_NAME(r4),CHF$L_MCH_SAVR0(r5) ; copy signame
$UNWIND_S ; Wipe out gracefully
movl #SS$_CONTINUE,r0 ; Continue from exception
20$: ret ; return to caller
;
;++
;
; HG$DEFINE_KEY - DEFINE/KEY
; 4(AP) - Key name descriptor
; 8(AP) - Key value descriptor
; 12(AP) - If_State string descriptor
; 16(AP) - Set_State string descriptor (null ok)
; 20(AP) - Flag address (SYM_M_* flags)
;
;--
.IF NDF,DISABLE_CMEXEC
key_name = 4
equivalence = 8
if_state = 12
set_state = 16
flags = 20
work_bytes = 512
.entry hg$define_key, ^m<r3,r10,r11>
cmpl #5,(AP)
beql 5$
movl #LIB$_WRONUMARG,r0
ret
5$: subl2 #work_bytes,sp
movl sp,r10 ; r10 --> template
; -- fill in template
clrl SYM_L_FL(r10) ; Clear fwd link
clrl SYM_L_BL(r10) ; Clear bck link
clrl SYM_L_ORDERED(r10) ; ORDERED link (unused in 4.5)
clrw SYM_W_FILELEVEL(r10) ; clear file level
mnegw #1,SYM_W_PROCLEVEL(r10) ; Set no procedure level ???
clrw SYM_W_BLOCKLEVEL(r10)
clrw SYM_L_BLOCKSEQ(r10)
clrw SYM_W_SIZE(r10) ; clear size
movb #SYM_K_KEYPAD,-
SYM_B_TYPE(r10) ; this is a keypad symbol
movl flags(AP),r0 ; get the flags
movw (r0),SYM_W_FLAGS(r10)
movab SYM_T_SYMBOL(r10),r3 ; template address of keyname
movl key_name(ap),r0 ; address of keyname descrip
movb (r0),(r3)+ ; copy length
movc3 (r0),@4(r0),(r3) ; copy string to template
movw @if_state(AP),r0 ; if state length
addw2 @equivalence(AP),r0 ; add equivalence length
tstl set_state(AP) ; is there a set_state?
beql 10$ ; nope... don't add it in
addw2 @set_state(AP),r0 ; add it in...
10$: addw2 #4,r0 ; +4 (number of length bytes)
movw r0,(r3)+ ; put sum next 3 field lengths
pushl r0 ; save length
movl if_state(AP),r1 ; address of if_state
movb (r1),(r3)+ ; copy length
movc3 (r1),@4(r1),(r3) ; copy string to template
movl equivalence(AP),r1 ; equivalence descriptor addr
movw (r1),(r3)+ ; copy length
movc3 (r1),@4(r1),(r3) ; copy string to template
movl set_state(AP),r1 ; is there a set_state?
beql 20$ ; nope... don't use it
movb (r1),(r3)+ ; copy length
movc3 (r1),@4(r1),(r3) ; copy string to template
bisw2 #SYM_M_STATE,- ; set STATE bit for caller
SYM_W_FLAGS(r10)
20$: clrb (r3)+ ; clear last byte of template
addl3 (SP)+,#SYM_T_SYMBOL+1,r0 ; calc size of template
addb2 SYM_T_SYMBOL(r10),r0 ; symbol name size
addl2 #2,r0 ; include word sum of 3 lengths
addl2 #7,r0 ; truncate to quad boundary
bicl2 #7,r0 ; round to next quad boundary
movw r0,SYM_W_SIZE(r10) ; set size of queue entry
$CMEXEC_S - ; do rest of job in exec
ROUTIN = exec_keydef ; (R10 is common data)
addl2 #work_bytes,sp ; give back work space (no need)
ret
;
; Exec routine to alloc and fill CLI memory
;
.entry exec_keydef, ^m<r3,r11>
movaw oops_catcher,(FP) ;set a safety net
moval G^CTL$AG_CLIDATA,r11
movl PPD$L_PRC(r11),r11
movab PRC_Q_ALLOCREG(r11),r3 ; get adddress of free memory
movzwl SYM_W_SIZE(r10),r1 ; size of block to allocate
jsb @#EXE$ALLOCATE ; alloc the memory
movl #LIB$_INSCLIMEM,r0 ; assume not enough memory
tstl r2 ; was space alloc'd?
beql 20$ ; nope... crap out
pushr #^m<r0,r1,r2,r3,r4,r5> ; save movc5 trashed registers
movc5 SYM_W_SIZE(r10),(r10),#0,-
r1,(r2) ; suck over the template
popr #^m<r0,r1,r2,r3,r4,r5> ; restore trashed registers
movw r1,SYM_W_SIZE(r10) ; set actual length alloc'd
bsbw find_place ; find place to insert it
insque SYM_L_FL(r2),@SYM_L_BL(r0) ; insert in que @r0
movl #SS$_NORMAL,r0 ; normal completion
20$: ret ; go home to user mode safety
;
; -- find place to stick in key definition
;
find_place:
pushr #^m<r1,r2,r3,r4,r5,r6,r7,r8,r9>
movab SYM_T_SYMBOL+1(r10),r1 ; get address of key name
movzbl -1(r1),r0 ; get key length
addl2 r0,r1 ; r1 --> word length of rest
incl r1 ; skip over word length
incl r1 ; r1 --> if_state string
movzbl (r1)+,r0 ; get the if_state length
pushl r1 ; put addr onstack
pushl r0 ; put len onstack
movzbl SYM_T_SYMBOL(r10),r8 ; r8 = len of key name
movab SYM_T_SYMBOL+1(r10),r9 ; r9 = addr of keyname
movl PRC_Q_KEYPAD(r11),r6 ; r6 --> first entry in queue
movab PRC_Q_KEYPAD(r11),r7 ; r7 --> beginning of queue
10$: cmpl r6,r7 ; EOQ yet?
beql 20$ ; yep -- bug out
movab SYM_T_SYMBOL+1(r6),r1 ; get address of keyname
movzbl -1(r1),r0 ; get length
addl2 r0,r1 ; r1 --> word length of rest
incl r1 ; skip over word length
incl r1 ; r1 --> if_state string
movzbl (r1)+,r0 ; get the if_state length
cmpc5 (sp),@4(sp),#^a/ /,r0,(r1) ; is this the same state?
blssu 20$ ; no - try next entry
bgtru 15$ ; if >, no ents for if_state
movzbl SYM_T_SYMBOL(r6),r0 ; get len of keynam in que
cmpc5 r8,(r9),#^a/ /,r0,SYM_T_SYMBOL+1(r6) ; comparem
blssu 20$ ; found place if key<qkey
bneq 15$ ; if not same, go try next
; - key already exists here
bsbw deletekey ; zap the current definition
brb 20$ ; return to caller
15$: movl SYM_L_FL(r6),r6 ; step forward into chain
brb 10$ ; ring-around-the-toilet again
20$: addl2 #8,sp ; clean up stack
movl r6,r0 ; retaddr
popr #^m<r1,r2,r3,r4,r5,r6,r7,r8,r9>
rsb
deletekey:
pushl r3 ; save
movab PRC_Q_ALLOCREG(r11),r3 ; allocation region listhead
remque SYM_L_FL(r6),r0 ; unlink it
movl SYM_L_FL(r0),r6 ; pick up 'new' current entry
movzwl SYM_W_SIZE(r0),r1 ; size to unload
jsb @#EXE$DEALLOCATE ; deallo the memory
popl r3 ; restore register
rsb ; backtocaller
.ENDC
;
; PUTMSG
; Simpleton's interface to $PUTMSG
;
.entry putmsg, ^m<>
$PUTMSG_S -
msgvec = (AP)
ret
;
; GETNODE
; Get the nodename of the current node
;
.entry getnode, ^m<r2,r3,r4,r5>
movc5 #0,#0,#^a/ /,nodeid,@nodeid+4 ;clear NODEID field
$GETSYIW_S -
ITMLST = syilst
blbc r0,10$
tstw nodeid
beql 10$
cmpb @nodeid+4,#^a/ /
beql 10$
brw 30$
10$: $TRNLNM_S -
TABNAM = lnmsys,-
LOGNAM = sysnod,-
ITMLST = trnls2
blbc r0,30$
subw #2,nodeid ;scrape off the trailing colons
brb 30$
20$: movl #0,nodeid ;set no logical name
30$: ret
;
;SYSLOGIN
; Get rooted pathname for SYS$LOGIN
;
.entry syslogin, ^m<>
movab @curdir+4,r1
movb #^a/[/,0(r1) ;poke in a ']'
movb #^a/]/,1(r1) ;poke in a ']'
movw #2,curdir ;set length 2
movc3 syslgi,@syslgi+4,@device+4
movw syslgi,device ;start out with this device
calls #0,inspth ;insert path
ret
inspth: .word ^m<r2,r3,r4,r5,r6,r7,r8,r9>
movw trn,r8
clrl atr
clrl r9 ;indicate initial run
clrb @trn+4
insrst: movw r8,trn
bbs #LNM$V_TERMINAL,atr,10$
cmpb @trn+4,#^a/_/
bneq 20$
10$: brw 60$
20$: $TRNLNM_S -
TABNAM = lnmfdv,-
LOGNAM = device,-
ITMLST = trnls1,-
ACMODE = exacmo
cmpl r0,#SS$_NOLOGNAM
bneqw 70$ ;more tranlation needed
$TRNLNM_S -
TABNAM = lnmjob,-
LOGNAM = device,-
ITMLST = trnls1,-
ACMODE = exacmo
cmpl r0,#SS$_NOLOGNAM
bneqw 70$ ;more tranlation needed
tstl r9 ;see if we've been here before
bneqw 60$ ;wasn't first NOLOGNAM
40$: $getuai_s - ;try the UAF for the login
usrnam = usrnam,-
itmlst = uailst
blbs r0,50$ ;looks like we got it
cmpl r9,#1 ;see if this is round #2
beql 60$ ;getouttahere... nothing worked
movw usrlen,usrnam ;reset username length
$idtoasc_s -
id = uic,-
namlen = usrnam,-
nambuf = usrnam ;get username assoc. w/uic
blbc r0,60$ ;that failed too...skipit
incl r9 ;set getuai retry flag
brb 40$ ;retry getuai w/new username
50$: movzbl defdev,r6 ;get len to stable reg
movc3 r6,defdev+1,@trn+4 ;zip device into place
addl3 trn+4,r6,r0 ;get address to put DIR
movzbl defdir,r7 ;length of DIR to stable reg
movc3 r7,defdir+1,(r0) ;stuffit
addw3 r6,r7,trn ;calculate new length for trans
brb 70$ ;try operation using UAF stuff
60$: brw pthext
70$: incl r9 ;flag successful translation
locc #^a/:/,trn,@trn+4 ;find the resultant colon
; beql oops ;better be one there
subl3 trn+4,r1,r6 ;length of device name in r2
movc3 r6,@trn+4,@device+4 ;copy for new device
movw r6,device ;set length
subw3 r6,trn,r7 ;set length of second part
bicl #^x0ffff0000,r7
decl r7 ;yank the colon we found
beql 99$
addl trn+4,r6 ;get source for next copy
incl r6 ;skip the colon
cmpb -1(r6)[r7],#^a/]/ ;strip a closing bracket
bneq 80$
decl r7 ;remove it
beql 99$
80$: cmpb -1(r6)[r7],#^a/./ ;strip trailing '.'
bneq 90$
decl r7
beql 99$
90$: movb #^a/./,@curdir+4 ;stuff in a separator
addl3 curdir+4,r7,r2 ;address of new stuff
movc3 curdir,@curdir+4,(r2) ;make space for new stuff
movc3 r7,(r6),@curdir+4
addw r7,curdir ;add in new space
99$: brw insrst
pthext: movq device,r6
bicl #^x0ffff0000,r6
movb #^a/:/,(r7)[r6]
incw device ;tack on a trailing colon
incw r6
addl3 r6,curdir+4,r2
movc3 curdir,@curdir+4,(r2) ;insert device
movc3 r6,@device+4,@curdir+4
addw r6,curdir
movaq curdir,r1
movzwl #SS$_NORMAL,r0
ret
;
; SETDSK
; Set sysdisk to new disk for CD
;
.entry setdsk, ^m<>
pushl #0 ;no itmlist
pushl #0 ;attribs
pushaq prctbl ;here is the table name
pushaq @4(AP) ;here is the value
pushaq sysdsk ;here is the logical to assign value to
calls #5,G^LIB$SET_LOGICAL
ret
;
; SETDEFDIR
; Set sysdefdir for other half of CD operation
;
.entry setdefdir, ^m<>
pushl #0 ;optional prams not present
pushl #0 ;optional parms not present
pushaq @4(AP) ;incoming value
calls #3,G^SYS$SETDDIR
ret
;
; SETDEF
; Complete CD Operation
;
.entry setdef, ^m<>
pushaq @4(AP) ;push directory sent
calls #1,setdefdir ;define it
pushaq @8(AP) ;push disk sent
calls #1,setdsk ;define that too
ret
;
; TRVSL0:
; traverses an item list and executes routine w/parms
;
; inputs: pushab getopt_<xxx>
; pushal itemlist
; pushaw routine
; outputs: r0 contains eolist from input itemlist
;
.entry trvsl0, ^m<r4,r6,r8>
movl 4(AP),r4 ;get exec routine address
movl 8(AP),r8 ;get data address
5$:
movl r8,r0 ;save current address
movl (r8)+,r6 ;load eoitem pointer
beql 20$ ;eolist
movzwl r6,r6 ;clear high word
addl r0,r6 ;calculate next item address
jsb @12(AP) ;check (r0) (r6)-n for class match
bneq 10$ ;skip item if not class matched
pushl r1 ;pass options/attributes
pushl r8 ;item to be defined
calls #2,(r4) ;do the function
10$: movl r6,r8 ;set next item address
jmp 5$ ;back for another main item
20$: movl r8,r0 ;return eolist in R0
ret
;
; TRVSL1:
; traverses an item list and executes routine w/parms
; item list is multi-argument
;
; inputs: [pushaq lv2dsc] ;level 2 descriptor
; pushab getopt_<xxx>
; pushal itemlist
; pushaw routine
; outputs: r0 contains eolist from input itemlist
;
.entry trvsl1, ^m<r4,r5,r6,r7,r8,r9>
movl 4(AP),r4 ;get exec routine address
movl 8(AP),r8 ;get data address
10$:
movl (r8)+,r7 ;get argcnt
bneq 15$ ;nzero pointer is neolist
brw 40$ ;zero pointer is eolist
15$: movl r8,r0 ;save current address
movl (r8)+,r6 ;load eoitem pointer
movzwl r6,r6 ;clear high word
addl r0,r6 ;calculate next item address
jsb @12(AP) ;check (r0) (r6)-n for class match
beql 20$ ;process item if EQL
movl r6,r8 ;jmp to item
17$: movl r8,r0 ;save current address
movzwl (r8),r8 ;load eoitem pointer
addl r0,r8 ;calculate next item address
sobgtr r7,17$ ;keep it up, 'til eolist
brw 10$ ;back for another main item
20$: movl #3,r5 ;initial item count
movl r8,r9 ;save initial item name address
30$: movl r6,r8 ;jmp to item
movl r8,r0 ;save current address
movl (r8)+,r6 ;load eoitem pointer
movzwl r6,r6 ;clear high word
addl r0,r6 ;calculate next item address
pushl r8 ;value descriptor
incl r5 ;another item for the calls
sobgtr r7,30$ ;keep it up, 'til eolist
clrl -(SP) ;no level 2 descriptor yet
cmpl (AP),#4 ;see if there's a level 2 descriptor
bneq 35$ ;no level 2 descriptor
movaq @16(AP),(SP) ;rewrite level 2 descriptor
35$: pushl r1 ;option longword
pushl r9 ;item to be defined
calls r5,(r4) ;do the function
movl r6,r8 ;jmp to first item
brw 10$ ;back for another main item
40$: movl r8,r0 ;return eolist in R0
ret
;
; TRVSL2:
; traverses list of itmlsts and executes routine w/parms
; using trvsl1
;
; inputs: pushab getopt_<xxx>
; pushal itemlistlist
; pushaw routine
; outputs: r0 contains eolist from input itemlist
;
.entry trvsl2, ^m<r4,r6,r8>
movl 4(AP),r4 ;get exec routine address
movl 8(AP),r0 ;get data address
10$:
movl r0,r1 ;save current address
movl (r0)+,r2 ;eotbl descriptor
beql 20$ ;eolist
movzwl r2,r2 ;clear high word
addl r1,r2 ;calculate eoitem address
pushl r0 ;level 2 descriptor
pushl 12(AP) ;pass operation type
pushl r2 ;item list list to be used
pushl 4(AP) ;push routine address
calls #4,trvsl1 ;do the function return new r0
brw 10$ ;back for another main item
20$: ret ;return eolist in r0
;
; GETOPT_DEFAULT:
; -- get item options default execute ... note JSB entry
; input: (r0) item header
; (r6) end of item calculated
; output: EQL - class match - perform operation
; r1 = 0 or OPTION
;
; all 0-items executed by all
; all nz-items executed if match to class
;
getopt_default:
clrl r1
bbc #0,2(r0),10$ ;skip option load
movl -4(r6),r1 ;load option
10$: bbs #1,2(r0),40$ ;must test further
20$: bispsw #^m<r2> ;set EQL condition (Z flag) (default)
rsb ;return condition
30$: bicpsw #^m<r2> ;set NEQ condition (Z flag)
rsb ;return condition
40$: bbs #0,2(r0),50$ ;code to skip option longword
bitl -4(r6),class ;test mask against membership classes
brb 60$ ;finish test
50$: bitl -8(r6),class ;test mask against membership classes
60$: beql 30$ ;no bits found...send NEQ return
brb 20$ ;bits found...send EQL return
;
; GETOPT_MEMBERS:
; -- get item options member-only execute ... note JSB entry
; input: (r0) item header
; (r6) end of item calculated
; output: EQL - class match - perform operation
; r1 = 0 or OPTION
;
; 0-items executed by classed only
; nz-items executed if match to class
;
getopt_members:
clrl r1
bbc #0,2(r0),10$ ;skip option load
movl -4(r6),r1 ;load option
10$: bbs #1,2(r0),40$ ;must test further
tstl class ;is a class specified??
bneq 30$ ;member of classes...ok to default
20$: bicpsw #^m<r2> ;set NEQ condition (Z flag)
rsb ;return condition
30$: bispsw #^m<r2> ;set EQL condition (Z flag) (default)
rsb ;return condition
40$: bbs #0,2(r0),50$ ;code to skip option longword
bitl -4(r6),class ;test mask against membership classes
brb 60$ ;finish test
50$: bitl -8(r6),class ;test mask against membership classes
60$: beql 20$ ;no bits found...send NEQ return
brb 30$ ;bits found...send EQL return
;
; GETOPT_INHIBIT:
; -- get item options inhibit default execute ... note JSB entry
; input: (r0) item header
; (r6) end of item calculated
; output: EQL - class match - perform operation
; r1 = 0 or OPTION
;
; 0-items executed by non-classed
; nz-items executed if match to class
;
getopt_inhibit:
clrl r1
bbc #0,2(r0),10$ ;skip option load
movl -4(r6),r1 ;load option
10$: bbs #1,2(r0),40$ ;must test further
tstl class ;is a class specified??
bneq 30$ ;member of classes...do not default
20$: bispsw #^m<r2> ;set EQL condition (Z flag) (default)
rsb ;return condition
30$: bicpsw #^m<r2> ;set NEQ condition (Z flag)
rsb ;return condition
40$: bbs #0,2(r0),50$ ;code to skip option longword
bitl -4(r6),class ;test mask against membership classes
brb 60$ ;finish test
50$: bitl -8(r6),class ;test mask against membership classes
60$: beql 30$ ;no bits found...send NEQ return
brb 20$ ;bits found...send EQL return
;
; GETOPT_PROTECTED:
; -- get item options execute only if member... note JSB entry
; input: (r0) item header
; (r6) end of item calculated
; output: EQL - class match - perform operation
; r1 = 0 or OPTION
;
; 0-items never executed
; nz-items executed if match to class
;
getopt_protected:
clrl r1
bbc #0,2(r0),10$ ;skip option load
movl -4(r6),r1 ;load option
10$: bbs #1,2(r0),40$ ;must test further
20$: bicpsw #^m<r2> ;set NEQ condition (Z flag)
rsb ;return condition
30$: bispsw #^m<r2> ;set EQL condition (Z flag) (default)
rsb ;return condition
40$: bbs #0,2(r0),50$ ;code to skip option longword
bitl -4(r6),class ;test mask against membership classes
brb 60$ ;finish test
50$: bitl -8(r6),class ;test mask against membership classes
60$: beql 20$ ;no bits found...send NEQ return
brb 30$ ;bits found...send EQL return
;
; REPLYDEFINER
; Designed to be called from trvsl0
; Sets operator class message flags
;
.entry replydefiner, ^m<>
movl 8(AP),enbcls ; set operator enable class
ret
;
; SETMESSDEFINER
; Designed to be called from trvsl0
; Sets message flags per DCL command $ SET MESSAGE/NOFACILITY... etc.
; Note: Uses $CMKRNL service. Use with caution on production equipment.
;
.IF NDF,DISABLE_CMKRNL
.entry setmessdefiner, ^m<r2,r3>
pushl 8(AP) ; incoming option is msg flags
pushl #1
moval (SP),r2
$CMKRNL_S -
ROUTIN = _setmess,-
ARGLST = (r2)
ret
.entry _setmess, ^m<>
movaw oops_catcher,(FP) ; set safety net
movb 4(AP),@#CTL$GB_MSGMASK ; set new message value
movzbl #SS$_NORMAL,r0 ; all is OK
ret
.ENDC
;
; DEFDIRDEFINER:
; designed to be called from trvsl0
; defines default directory from OPTION(address) passed in
;
.entry defdirdefiner,^m<>
moval @8(AP),actdir ;set active default drive
ret
;
; DEFDRVDEFINER:
; designed to be called from trvsl0
; defines default drive from OPTION(address) passed in
;
.entry defdrvdefiner,^m<>
moval @8(AP),actdrv ;set active default drive
ret
;
; DEFBRODEFINER:
; designed to be called from trvsl0
; defines default broadcast from OPTION(address) passed in
;
.entry defbrodefiner,^m<>
moval @8(AP),actbro ;set active default broadcast
ret
;
; DEFONDEFINER:
; designed to be called from trvsl0
; defines default TTON from OPTION(address) passed in
;
.entry defondefiner,^m<>
moval @8(AP),acton ;set active default TTON chars
ret
;
; DEFOFFDEFINER:
; designed to be called from trvsl0
; defines default TTOFF from OPTION(address) passed in
;
.entry defoffdefiner,^m<>
moval @8(AP),actoff ;set active default TTOFF chars
ret
;
; DEFPRVDEFINER:
; designed to be called from trvsl0
; defines default privileges from OPTION(address) passed in
;
.entry defprvdefiner,^m<>
movq @8(AP),actprv ;move default privileges
ret
;
; DEFPRODEFINER:
; designed to be called from trvsl0
; defines default protection from OPTION passed in
;
.entry defprodefiner,^m<>
pushl 8(AP)
moval (SP),r1
pushl #0 ;I couldn't care less what it was
pushaw (r1) ;I want it set to this!
calls #2,G^SYS$SETDFPROT ;Do the set prot xxx/def
ret
;
; DEFPRCDEFINER:
; designed to be called from trvsl0
; defines default processname list from OPTION(address) passed in
;
.entry defprcdefiner,^m<>
moval @8(AP),actprc ;move default processnames
ret
;
; DEFPRMDEFINER:
; designed to be called from trvsl0
; defines DCL prompt descriptor address from OPTION(address) passed in
;
.entry defprmdefiner,^m<>
moval @8(AP),actprm ;move prompt address
ret
;
; VERDEFINER:
; designed to be called from trvsl0
; defines verify status from OPTION(address) passed in
;
.entry verdefiner,^m<>
addl3 #1,8(AP),verify ;set verify state +1
ret
;
; DODEFINER:
; designed to be called from trvsl0
; defines final 'do' command address from OPTION(address) passed in
;
.entry dodefiner,^m<>
movaq @8(AP),actdo ;insert address of 'do' list
ret
;
; SYMKILLER:
; designed to be called from trvsl0
; deletes symbols based on input parameters
; this routine expects EXACTLY ONE parameter
;
.entry symkiller, ^m<r2,r3>
pushal tblind ;annunciate these to global table
pushaq @4(AP) ;item pointer
calls #2,G^LIB$DELETE_SYMBOL
ret ;go home
;
; SYMDEFINER:
; designed to be called from trvsl1
; assigns values to symbols based on input parameters
; this routine expects EXACTLY FOUR parameters
; Note that OPTION is ignored
;
.entry symdefiner, ^m<r2,r3>
cmpl #4,(AP) ;see if multi-parms
bneq 20$ ;deny invalid parameter count
pushal tblind ;annunciate these to global table
pushaq @16(AP) ;symbol value
pushaq @4(AP) ;symbol name
calls #3,G^LIB$SET_SYMBOL
cmpl r0,#SS$_NORMAL ;is all ok?
beql 10$ ;it's ok
$EXIT_S CODE=r0 ;barf if I don't understand the error
10$: ret ;go home
20$: pushaq @4(AP) ;address of symbol being defined
pushl #1 ;1 FAO parameter
pushl #STP_SYMMES ;this message
calls #3,putmsg ;dump it
$EXIT_S ;bug out
;
; LOGDEFINER:
; designed to be called from trvsl1
; assigns values to logicals based on input parameters
; this routine expects two or more parameters
; if there are three or more parameters, a list of values is defined
; lv2dsc (longword) is expected to contain a pointer to a table_name
; descriptor.
;
.entry logdefiner, ^m<r2,r3,r4,r5>
movl (AP),r2 ;numargs
cmpl #4,r2 ;see if multi-parms
beql 5$ ;no...process single parm
brw 40$ ;process list
5$: movl 8(AP),-(SP) ;save incoming attributes
clrl -(SP) ;no itmlist
pushal 4(SP) ;attribs
pushaq @12(AP) ;here is the table name
beql 30$ ;none specified...bomb
movq @16(AP),r0 ;get value descriptor
cmpw r0,#1 ;see if it's one byte long
bneq 10$ ;not one byte long
cmpb (r1),#^a/*/ ;test for '*'
bneq 10$ ;Not a '*'
pushaq curdir ;define this one as rooted logical
brb 20$ ;skip valpush
10$: pushaq @16(AP) ;here is the value
20$: pushaq @4(AP) ;here is the logical to assign value to
calls #5,G^LIB$SET_LOGICAL
cmpl r0,#SS$_NORMAL ;see if ok
beql lexit ;yep
cmpl r0,#SS$_SUPERSEDE ;supersedes are allowed w/o error
beql lexit ;yep
$EXIT_S CODE=r0 ;leavus (i don't understand error)
30$: pushl #STP_NOTBL
calls #1,putmsg
$EXIT_S
40$:
moval 16(AP),r3 ;addr of last val (first val arg) item
movl 8(AP),-(SP) ;options
moval (SP),r5 ;address of options longword
pushl #0 ;list terminator
subl #3,r2 ;rmv cnt for main item, option, &lv2dsc
50$: ;form ITEM_LIST_3 on stack
pushl #0 ;ret ^
movl (r3)+,r1 ;get address of descriptor
pushl 4(r1) ;push address of string
movzwl (r1),r1 ;get length to r1
bisl #LNM$_STRING@16,r1 ;place code into high r1
pushl r1 ;this is the code/length of the item
sobgtr r2,50$ ;place all items into list
movl 8(AP),(r5) ;copy options/attributes
pushal (SP) ;pointer to itemlist
pushal (r5) ;attribs
pushaq @12(AP) ;here is the table name
beql 30$ ;none specified...bomb
pushl #0 ;values are specified in itmlst
pushaq @4(AP) ;logical name
calls #5,G^LIB$SET_LOGICAL
cmpl r0,#SS$_NORMAL ;see if ok
beql lexit ;yep (restore stack)
cmpl r0,#SS$_SUPERSEDE ;supersedes are allowed w/o error
beql lexit ;yep (restore stack)
$EXIT_S CODE=r0 ;leavus (I don't understand error)
lexit: ret ;go home
;
; KEYDEFINER:
; designed to be called from trvsl1
; assigns definitions to keys based on input parameters
; this routine expects two or three parameters
; if there are three or more parameters, program will error exit
; lv2dsc (longword) is expected to contain a pointer to an IF_STATE
; descriptor.
;
.IF NDF,DISABLE_CMEXEC
.entry keydefiner, ^m<r2,r3,r4,r5>
movl 8(AP),-(SP) ;save incoming attributes
pushal (SP) ;flags address
clrl -(SP) ;setstate
pushaq @12(AP) ;ifstate
beql 15$ ;no ifstate...bug it
pushaq @16(AP) ;equivalence value
pushaq @4(AP) ;keyname ... all args pushed now
cmpl #4,(AP) ;see if setstate specified
beql 10$ ;nope...issue call as-is
cmpl #5,(AP) ;see if exactly & only setstate spec'd
bneq 20$ ;nope...error...multidef
movaq @20(AP),4(SP) ;rewrite equivalence value arg
movaq @16(AP),12(SP) ;use first extra arg as setstate
10$: calls #5,hg$define_key ;do key definition
ret
15$: pushl #STP_NOIFST ;use this message
calls #1,putmsg ;output text
$EXIT_S ;get lost
20$: pushaq @4(AP) ;pass keyname to putmsg
pushl #1 ;1 FAO parameter
pushl #STP_KYMMES ;use this message text
calls #3,putmsg ;output message
$EXIT_S ;barf out
.ENDC
;
; REPLY_ENABLE
; Enables operator console if privilege exists to do so
;
.entry reply_enable, ^m<>
pushab getopt_protected;op squelched 'cept for members
pushal opcmsk ;data address
pushaw replydefiner ;define reply mask
calls #3,trvsl0 ;traverse list, def reply mask
tstl enbcls ;was something set???
bneq 5$ ;yes... try to do it
ret ;nope... ignore rest
5$: $GETDVIW_S - ;get terminal name, unitno
DEVNAM = ttnam,-
ITMLST = dvilst
blbcw r0,40$ ;retrieve terminal name/unitno
movab devnam,r0 ;get name's address
addl retlen,r0 ;jump 1 past end char
decl r0 ;set address of last character
cmpb (r0),#^a/:/ ;if it is not a colon
bneq 10$ ;don't skip a character
decl r0 ;else skip colon
10$: cmpb (r0),#^a/0/ ;backup over all numeric
blssu 20$ ;oops... not numeric... keep
cmpb (r0),#^a/9/ ;backup over all numeric
bgtru 20$ ;oops... not numeric... keep
decl r0 ;backup one character
brb 10$ ;muck thru this stuff again
20$: subl3 #devnam-1,r0,retlen ;calculate remaining length
movb retlen,devnml ;move to ascic len byte
addw retlen,enbdsc ;add to message descriptor
movw retunt,unit ;move in the unit number
$SETPRV_S - ;try to get OPER privilege
PRMFLG = #0,- ;try temporary privs
ENBFLG = #1,-
PRVADR = oprprv
blbcw r0,40$ ;oops... error... bugout
movl r0,r1 ;save status
movl #SS$_NOOPER,r0 ;set NOOPER error
cmpl r1,#SS$_NOTALLPRIV ;see if we didn't get OPER
beql 40$ ;no OPER... return error
$SETPRV_S - ;try to get SECURITY privilege
PRMFLG = #0,- ;try temporary privs
ENBFLG = #1,-
PRVADR = secprv
blbc r0,40$ ;oops... error... bugout
cmpl r1,#SS$_NOTALLPRIV ;see if we didn't get SECURITY
bneq 30$ ;SECURITY... default request
bicl #OPC$M_NM_SECURITY,enbcls ;rmv SECURITY from OPCOM req.
30$: $SNDOPR_S - ;try to enable us as operator
MSGBUF = enbdsc
40$: ret ;return all errors
;
; TIMOUT
; Timeout routine in case of high priority hangup
;
.entry timout, ^m<>
$SETPRV_S - ;attempt a priority boost
ENBFLG = #1,-
PRMFLG = #0,-
PRVADR = booprv
$SETPRI_S -
PRI = norpri ;drop back down
$SETSWM_S -
SWPFLG = #0 ;release lock
ret
;
; SETTMO
; Set timeout timer in case of programming error
;
.IF NDF,DISABLE_BOOST
settmo:
$BINTIM_S - ;Convert time to binary
TIMBUF = asctim,-
TIMADR = bintim
blbc r0,10$
$SETIMR_S - ;Set countdown killer
DAYTIM = bintim,-
ASTADR = timout
blbc r0,10$
rsb
10$: $EXIT_S -
CODE = r0
.ENDC
;
; functional routines
; each routine is called from mainline via JSB entry
; all registers may be scratched
;
; Attempt to identify the current node and set class mask accordingly
setnode:
calls #0,getnode ;get nodename
clrl class ;set no classes
movl #NODE_COUNT,r2
moval NODE_GL_LIST,r3
10$: movl (r3)+,r4
movaq 4(r4),r5
movl (r4),r4
cmpw nodeid,(r5) ;see if lengths match
bneq 20$
pushr #^m<r2,r3,r4,r5>
cmpc3 nodeid,@nodeid+4,@4(r5) ;see if chars match
popr #^m<r2,r3,r4,r5>
bneq 20$
movl r4,class ;set classes
movl r5,node
brb 30$
20$: sobgtr r2,10$
pushaq nodeid
pushl #2
pushl #STP_NODMES
calls #3,putmsg
30$: rsb
;
; Define symbol NODE
defnode:
pushal tblind ;annunciate these to global table
pushaq nodeid ;symbol value
pushaq nodes ;symbol name
calls #3,G^LIB$SET_SYMBOL
rsb
;
; Define MODE symbol
defmode:
$GETJPIW_S -
ITMLST = jpilst
movl modev,r0 ;index value
ashl #2,r0,r0 ;index table of longwords
pushal tblind ;annunciate these to global table
pushaq @model(r0) ;symbol value
pushaq modes ;symbol name
calls #3,G^LIB$SET_SYMBOL
rsb
;
; Define $MODE numeric
defmnum:
$FAO_S -
CTRSTR = numctl, -
OUTLEN = modval, -
OUTBUF = modval, -
P1 = modev
pushal tblind ;annunciate these to global table
pushaq modval ;symbol value
pushaq moden ;symbol name
calls #3,G^LIB$SET_SYMBOL
rsb
;
; Define QUEUE_NAME and ENTRY_NUMBER if in batch mode
defqueue:
cmpl #2,modev ;Are we in batch mode?
beql isbat ;nope... skip the batch stuff
brw nobat ;nope... skip the batch stuff
isbat: $GETQUIW_S -
FUNC = #qui$_display_job,-
ITMLST = quilst,-
IOSB = quiosb
blbcw r0,nobat ;$QUI doesn't think all's well
movl quiosb,r0 ;get $QUI iosb status
blbcw r0,nobat ;$QUI doesn't think we're batch
$GETQUIW_S -
FUNC = #qui$_cancel_operation
$GETQUIW_S -
FUNC = #qui$_display_queue, -
ITMLST = quils2, -
IOSB = quiosb
blbc r0,qunok
blbs quiosb,quok
movl quiosb,r0
qunok: ret
quok: $GETQUIW_S -
FUNC = #qui$_cancel_operation
pushal tblind ;annunciate these to global table
pushaq quenam ;symbol value
pushaq qnmsym ;symbol name
calls #3,G^LIB$SET_SYMBOL
$FAO_S -
CTRSTR = numctl, -
OUTLEN = entval, -
OUTBUF = entval, -
P1 = entno
pushal tblind ;annunciate these to global table
pushaq entval ;symbol value
pushaq entsym ;symbol name
calls #3,G^LIB$SET_SYMBOL
nobat: rsb
;
; Remove all unwanted symbols (ignore errors)
remsym:
pushab getopt_default ;operation performed by default
pushal hitlst ;data address
pushaw symkiller ;delete symbols
calls #3,trvsl0 ;traverse list and kill symbols
rsb
;
; Define symbols
defsym:
pushab getopt_default ;operation performed by default
pushal symlst ;data address
pushaw symdefiner ;define symbols
calls #3,trvsl1 ;traverse list and define symbols
rsb
;
; Define all logicals
deflog:
calls #0,syslogin ;setup rooted logical string
pushab getopt_default ;operation performed by default
pushal loglst ;list of logicals and tables
pushaw logdefiner ;this is the routine for lvl1 lists
calls #3,trvsl2 ;return nothing meaningful
rsb
;
; Define all keys (if DISABLE_CMEXEC not defined)
.IF NDF,DISABLE_CMEXEC
defkeys:
tstl keycls ;test required class mask
beql 5$ ;no classes required
mcoml keycls,r0 ;invert for BICL
bicl3 r0,class,r0 ;leave only bits to test
cmpl r0,keycls ;see if all requested bits present
bneq 20$ ;class(es) do not permit operation
5$: cmpl modev,#JPI$K_INTERACTIVE ;Are we INTERACTIVE?
bneq 20$ ;Nope, dont try key defs
$SETPRV_S - ;get cme
ENBFLG = #1,-
PRMFLG = #0,-
PRVADR = cmeprv
cmpl r0,#SS$_NOTALLPRIV
bneq 10$
pushl #STP_CMEMES
calls #1,putmsg
brb 20$
10$: pushab getopt_default ;operation performed by default
pushal keylst ;list of key definitionsh
pushaw keydefiner ;this is the routine for lvl1 lists
calls #3,trvsl2 ;return nothing meaningful
$SETPRV_S - ;drop cme
ENBFLG = #0,-
PRMFLG = #0,-
PRVADR = cmeprv
20$: rsb
.ENDC
;
; Set message flag (if CMKRNL)
.IF NDF,DISABLE_CMKRNL
setmsg:
tstl msfcls ;test required class mask
beql 23$ ;no classes required
mcoml msfcls,r0 ;invert for BICL
bicl3 r0,class,r0 ;leave only bits to test
cmpl r0,msfcls ;see if all requested bits present
bneq 27$ ;class(es) do not permit operation
23$: $SETPRV_S - ;get cmk
ENBFLG = #1,-
PRMFLG = #0,-
PRVADR = cmkprv
cmpl r0,#SS$_NOTALLPRIV
bneq 25$
pushl #STP_CMKMES
calls #1,putmsg
brb 27$
25$:
pushab getopt_inhibit ;operation performed only if mask match
pushal defmsg ;data address
pushaw setmessdefiner ;set message flags
calls #3,trvsl0 ;traverse list and set flags
$SETPRV_S - ;drop cmk
ENBFLG = #0,-
PRMFLG = #0,-
PRVADR = cmkprv
27$: rsb
.ENDC
;
; Set up terminal if interactive
ttsetup:
cmpl modev,#JPI$K_INTERACTIVE ;Are we INTERACTIVE?
beql 10$ ;Nope, dont try tt setup
brw 40$
10$: clrl ttchn
$ASSIGN_S - ;get a channel to the tt:
DEVNAM = ttnam,-
CHAN = ttchn
blbs r0,15$
clrl ttchn ;make sure it's 0 for err's
brw 40$
15$: clrl actbro ;zap active broadcast to zeroes
pushab getopt_inhibit ;operation performed only if mask match
pushal ttbro ;data address
pushaw defbrodefiner ;set default broadcast classes
calls #3,trvsl0 ;traverse list and set flags
tstl actbro ;see if actbro got set up
beql 20$ ;leave 'em alone if not defined
$qiow_s - ;force broadcast classes
chan = ttchn,-
func = #IO$_SETMODE!IO$M_BRDCST,-
p1 = @actbro,-
p2 = #8
blbs r0,20$
brw 40$
20$: $qiow_s - ;read soft terminal chars
chan = ttchn,-
func = #IO$_SENSEMODE,-
p1 = ttchr,-
p2 = #12
clrl actoff ;no 'off' by default
pushab getopt_inhibit ;operation performed only if mask match
pushal ttoff ;data address
pushaw defoffdefiner ;set default TTOFF
calls #3,trvsl0 ;traverse list and set flags
clrl acton ;no 'on' by default
pushab getopt_inhibit ;operation performed only if mask match
pushal tton ;data address
pushaw defondefiner ;set default TTON
calls #3,trvsl0 ;traverse list and set flags
moval @actoff,r0 ;get address of TTOFF chars
beql 25$ ;skip TTOFF actions
bicl (r0),ttchr ;turn off these
bicl 4(r0),ttchr+4 ;turn off these
bicl 8(r0),ttchr+8 ;turn off these
25$: moval @acton,r0 ;get address of TTON chars
beql 33$ ;skip TTON actions
bisl (r0),ttchr ;turn on these
bisl 4(r0),ttchr+4 ;turn on these
bisl 8(r0),ttchr+8 ;turn on these
33$: $qiow_s - ;reset soft terminal chars
chan = ttchn,-
func = #IO$_SETMODE,-
p1 = ttchr,-
p2 = #12
40$: rsb
;
; Enable operator console
enbopr:
cmpl modev,#JPI$K_INTERACTIVE ;Are we INTERACTIVE?
bneq 43$ ;Nope, dont try console
calls #0,reply_enable
43$: rsb
;
; Set Default protection on files
setpro:
pushab getopt_inhibit ;op not performed by default
pushal defpro ;data address
pushaw defprodefiner ;define default protection
calls #3,trvsl0 ;traverse list, def defpro
rsb
;
; Set Default privs
setprv:
$SETPRV_S -
ENBFLG = #0,- ;reset the named privs
PRVADR = offmsk,- ;zap'em all
PRMFLG = #1,- ;affect process privs
PRVPRV = actprv ;use previous privs if none found
movl modev,r0 ;index value
ashl #2,r0,r0 ;index table of longwords
pushab getopt_inhibit ;op not performed by default
pushal @modepr(r0) ;data address
pushaw defprvdefiner ;define default priv mask
calls #3,trvsl0 ;traverse list, def defprv
$SETPRV_S -
ENBFLG = #1,- ;set the named privs
PRVADR = actprv,-;set the new ones
PRMFLG = #1 ;affect process privs
rsb
;
; Set directory by mode
setdir:
movl modev,r2 ;index value
ashl #3,r2,r2 ;index table of quadwords
clrl actdrv ;set no active drive
pushab getopt_inhibit ;op not performed by default
pushal @modecd(r2) ;data address
pushaw defdrvdefiner ;define drive mask
calls #3,trvsl0 ;traverse list, def reply mask
addl #4,r2 ;point second half of quadword
clrl actdir ;set no active directory
pushab getopt_inhibit ;op not performed by default
pushal @modecd(r2) ;data address
pushaw defdirdefiner ;define drive mask
calls #3,trvsl0 ;traverse list, def reply mask
tstl actdrv ;was one selected?
beql 50$
pushaq @actdrv ;default drive
tstl actdir ;was one selected?
beql 50$
pushaq @actdir ;directory
calls #2,setdef ;set defdir
50$: rsb
$SETPRV_S - ;get cme
ENBFLG = #1,-
PRMFLG = #0,-
PRVADR = cmeprv
cmpl r0,#SS$_NOTALLPRIV
bneq 10$
pushl #STP_CMEMES
calls #1,putmsg
brb 20$
10$: pushab getopt_default ;operation performed by default
pushal keylst ;list of key definitionsh
pushaw keydefiner ;this is the routine for lvl1 lists
calls #3,trvsl2 ;return nothing meaningful
$SETPRV_S - ;drop cme
ENBFLG = #0,-
PRMFLG = #0,-
PRVADR = cmeprv
20$: rsb
;
; Set DCL prompt if INTERACTIVE
.IF NDF,DISABLE_CMSUPER
setprm:
cmpl modev,#JPI$K_INTERACTIVE ;Are we INTERACTIVE?
bneq 10$ ;Nope, dont set prompt
$SETPRV_S - ;get cme
ENBFLG = #1,-
PRMFLG = #0,-
PRVADR = cmeprv
cmpl r0,#SS$_NOTALLPRIV
bneq 5$
pushl #STP_CMSMES
calls #1,putmsg
brb 10$
5$: clrl actprm ;no active prompt
pushab getopt_protected;op squelched 'cept for members
pushal prmlst ;list of processname lists
pushaw defprmdefiner ;define prompts
calls #3,trvsl0 ;traverse list, def prcnam
tstl actprm ;was one found?
bneq 20$
10$: $SETPRV_S - ;drop cme
ENBFLG = #0,-
PRMFLG = #0,-
PRVADR = cmeprv
rsb
20$: moval @actprm,r2 ;address of TTMATCH list
brb 40$ ;start search
30$: addl #5*4,r2 ;jmpto next item
40$: tstl (r2) ;address of prompt descrip zero = eolist
beql 10$ ;eolist reached
tstl 8(r2) ;was a tt type spec'd
beql 50$ ;nope... skipcheck
cmpb 8(r2),ttchr+1 ;does spec'd type match?
bneq 30$ ;nope... goto next item
50$: tstl 12(r2) ;were TT primary attribs spec'd?
beql 60$ ;go test TT2$ attribs
mcoml 12(r2),r1 ;prep test
bicl3 r1,ttchr+4,r3 ;mask to only rqst'd chars
mcoml r1,r1 ;re-invert mask
cmpl r3,r1 ;are all rqst'd chars present?
bneq 30$ ;nope... keep testing
60$: tstl 16(r2) ;were TT secondary attribs spec'd?
beql 70$ ;accept as matched
mcoml 16(r2),r1 ;prep test
bicl3 r1,ttchr+8,r3 ;mask to only rqst'd chars
mcoml r1,r1 ;re-invert mask
cmpl r3,r1 ;are all rqst'd chars present?
bneq 30$ ;nope... keep testing
70$: movaq @4(r2),r0 ;get setup descrip address
beql 80$ ;jmp if no setup spec'd
movq @4(r2),r0 ;get setup descrip to r0'r1
movzwl r0,r0 ;blast descriptor stuff
$qiow_s - ;write setup for prompt
chan = ttchn,-
func = #IO$_WRITEVBLK,-
p1 = (r1),-
p2 = r0
80$: pushaq @(r2) ;push address of prompt string
calls #1,90$ ;generate call frame
rsb ;backto mainline
90$: .word 0 ;cmexec call w/arglst
$cmexec_s - ;goto exec to vector to super
routin = 100$,-
arglst = (AP) ;CMEXEC using CALLS arglst
ret ;return to subroutine
100$: .word 0
$dclast_s - ;vector to supervisor mode
astadr = 110$,-
astprm = AP,- ;use passed arglst as ASTPRM
acmode = #PSL$C_SUPER
ret ;back from cmexec fires super
110$: .word ^m<r2,r3,r4,r5> ;MOVCx trashes these registers
calls #0,@#EXE$CLRAST ;get out of AST mode
moval g^CTL$AG_CLIDATA,r2 ;get cli data address
movl PPD$L_PRC(r2),r2 ;get process region address
movl 4(AP),AP ;recover $CMEXEC AP
movaq @4(AP),r0 ;get address of prompt string
addb3 #3,(r0),PRC_B_PROMPTLEN(r2) ;changeto DCL len req's (CRLF_)
movc5 (r0),@4(r0),#0,#32,PRC_G_PROMPT(r2) ;prompt insert, max=32 char
ret ;getlost
.ENDC
;
; Set DCL verify if INTERACTIVE
.IF NDF,DISABLE_CMSUPER
setver:
$SETPRV_S - ;get cme
ENBFLG = #1,-
PRMFLG = #0,-
PRVADR = cmeprv
cmpl r0,#SS$_NOTALLPRIV
beql 10$
movl modev,r2 ;index value
ashl #2,r2,r2 ;index table of longwords
clrl verify ;no 'set verify' by default
pushab getopt_protected;op squelched 'cept for members
pushal @modevf(r2) ;data address
pushaw verdefiner ;define verify
calls #3,trvsl0 ;traverse list, def prcnam
tstl verify ;was a state found?
bneq 20$ ;yes... go do it
10$: $SETPRV_S - ;get cme
ENBFLG = #0,-
PRMFLG = #0,-
PRVADR = cmeprv
rsb
20$: subl3 #1,verify,-(SP) ;push new verify state
calls #1,30$ ;generate call frame
rsb ;backto mainline
30$: .word 0 ;cmexec call w/arglst
$cmexec_s - ;goto exec to vector to super
routin = 40$,-
arglst = (AP) ;CMEXEC using CALLS arglst
ret ;return to subroutine
40$: .word 0
$dclast_s - ;vector to supervisor mode
astadr = 50$,-
astprm = AP,- ;use passed arglst as ASTPRM
acmode = #PSL$C_SUPER
ret ;back from cmexec fires super
50$: .word ^m<r2,r3,r4,r5> ;MOVCx trashes these registers
calls #0,@#EXE$CLRAST ;get out of AST mode
moval g^CTL$AG_CLIDATA,r2 ;get cli data address
movl PPD$L_PRC(r2),r2 ;get process region address
movl 4(AP),AP ;recover $CMEXEC AP
tstl 4(AP) ;was verify rqst'd?
bneq 60$ ;yes... setit
bicw #PRC_M_VERIFY,PRC_W_FLAGS(r2) ;turn verify off
ret ;getlost
60$: bisw #PRC_M_VERIFY,PRC_W_FLAGS(r2) ;turn verify on
ret ;getlost
.ENDC
;
; Set processname if possible
setprc:
clrl r4 ;maxtry counter
$GETTIM_S -
TIMADR = time ;read system time
clrl actprc ;no active process name
pushab getopt_inhibit ;op not performed by default
pushal prclst ;list of processname lists
pushaw defprcdefiner ;define processnames
calls #3,trvsl0 ;traverse list, def prcnam
rstspn: moval @actprc,r2 ;processnames
beql eoprc ;none found... skipit
extzv #5,#3,time,r3 ;mask low to 3 bits in r1
addl r4,r3 ;add in current index
bicb #^xf8,r3 ;zapto 0..7
incl r3 ;start at 1
newprc: movl r2,r1 ;next address for forwardlink load
movl r2,r0 ;save for nextitem calculation
movzwl (r1),r2 ;pick up next item offset in r2
addl r0,r2 ;calculate nextitem
sobgtr r3,newprc ;loop thru list 'til at desired item
$SETPRN_S -
PRCNAM = 4(r1) ;set processname
blbs r0,eoprc ;branch on success
aoblss #^x20,r4,rstspn ;try again until retries are burned up
eoprc: rsb
;
; Do final command if applicable
docmd:
movl modev,r2 ;index value
ashl #2,r2,r2 ;index table of longwords
clrl actdo ;no 'do' by default
pushab getopt_protected;op squelched 'cept for members
pushal @modedo(r2) ;data address
pushaw dodefiner ;define 'do' address
calls #3,trvsl0 ;traverse list, def 'actdo'
tstl actdo ;was one selected?
bneq 10$
rsb
10$: pushaq @actdo ;address of command to do
calls #1,g^LIB$DO_COMMAND
$exit_s - ;we shouldn't ever get here!
code = #SS$_BUGCHECK
;
; Initialization processing
init_self:
movaw oops_catcher,(FP) ;set trap (shut down boost code)
.IF NDF,DISABLE_BOOST
$SETPRV_S - ;attempt a priority boost
ENBFLG = #1,-
PRMFLG = #0,-
PRVADR = booprv
$DCLEXH_S -
DESBLK = extblk ;set exit handler (shut down boost code)
$SETSWM_S -
SWPFLG = #1 ;lock us in memory temporarily
$SETPRI_S -
PRI = #boopri ;Temporary boost value
bsbw settmo ;set timeout routine in case prog err.
.ENDC
rsb
;
; End processing
endprc:
$SETPRV_S - ;priority boost disable
ENBFLG = #1,-
PRMFLG = #0,-
PRVADR = booprv
$SETPRI_S -
PRI = norpri ;drop back down
$SETSWM_S -
SWPFLG = #0 ;release lock
$CANEXH_S -
DESBLK = extblk ;No need to do this...already done
movzwl #SS$_NORMAL,r0
rsb
;
; SETUP
; Main program entry point
;
.entry setup, ^m<>
; Initialization processing
bsbw init_self
; Attempt to identify the current node and set class mask accordingly
bsbw setnode
; Define symbol NODE
bsbw defnode
; Define MODE symbol
bsbw defmode
; Define $MODE numeric
bsbw defmnum
; Define QUEUE_NAME and ENTRY_NUMBER if in batch mode
bsbw defqueue
; Remove all unwanted symbols (ignore errors)
bsbw remsym
; Define symbols
bsbw defsym
; Define all logicals
bsbw deflog
; Define all keys (if DISABLE_CMEXEC not defined)
.IIF NDF,DISABLE_CMEXEC, bsbw defkeys
; Set message flag (if CMKRNL)
.IIF NDF,DISABLE_CMKRNL, bsbw setmsg
; Set up terminal if interactive
bsbw ttsetup
; Enable operator console
bsbw enbopr
; Set Default protection on files
bsbw setpro
; Set Default privs
bsbw setprv
; Set directory by mode
bsbw setdir
; Set DCL prompt if INTERACTIVE
.IIF NDF,DISABLE_CMSUPER, bsbw setprm
; Set DCL verify if INTERACTIVE
.IIF NDF,DISABLE_CMSUPER, bsbw setver
; Set processname if possible
bsbw setprc
; End processing
bsbw endprc
; Final exit command (if applicable)
pushl r0
bsbw docmd
popl r0
ret
.end SETUP