.TITLE SYSPAK -- EXECUTIVE DIRECTIVE CALLER .IDENT /V1.03/ .ENABL LC .PSECT SYSPAK,RO,I,LCL,CON ; INTERFACE TO CALL ANY RSX-11M EXECUTIVE DIRECTIVE FROM BASIC-11 V02-0 ; ; Author: C J Doran ; ; COPYRIGHT (C) 1982,1986 Sira Ltd., ; South Hill, Chislehurst, Kent, BR7 5EH, England. ; ; Assemble as: ; >MAC SYSPAK=LB:[11,10]RSXMC/PA:1,SY:[g,m]BMAC,ASSEM,SYSPAK ; ; Where BMAC.MAC and ASSEM.MAC are supplied on the BASIC source disk. ; ; Modify and re-assemble CALLI as described in the BASIC users' guide (Chap 4) ; and rebuild as described in the BASIC installation guide. ;+ ; Modifications Record: ; ===================== ; V1.02 28-Aug-86 CJD ; Attach/detach using subroutines in IOPK2 (mainly because unsolicited ; character trap is now there. ; Correct bugs in DCL etc., incorrectly referring to %1 instead of ; required items!! ; Handle 8-word esb block (returning only first). VAX-11 RSX V2.1 ; always returns 8 words, regardless of absence of SP.WX8. ; ; V1.03 29-OCT-86 CJD ; Must set R5 to point to workspace area before calling DTTCH/ATTCH. ; ; This module contains three subroutines, which may be accessed through BASIC's ; CALL interface: ; ; GETADR ; ------ ; 100 CALL "GETADR"(D%()[,a1,a2,a3,...an]) ; ; where a1 to an are a list of names of variables (of any type) whose addresses ; are to be placed in the corresponding elements of D%(1 ... n). This enables ; the setting up of a directive parameter block which must contain actual ; addresses of data items. Note that D%(0) is not intiialised, as this will ; contain the directive code (DIC) itself (see below). Further, any element ; which is explicitly blank will not be changed, nor will any elements after ; the n'th. It is the user's responsibility to ensure that the array is ; dimensioned big enough. The only check that can be made is that there is ; at least one argument, D%(), and that it is dimensioned. (The latter ; check is made by BASIC itself.) ; ; Example: ; 100 CALL "GETADR"(A%(),B$,,L%,F()) ; ; Sets A%(1) to the address of string B$, A%(3) to the address of integer ; L%, and A%(4) to the address of floating-point array F). A%(2) is not ; changed. ; ; ; SYSTEM ; ------ ; 200 CALL "SYSTEM"(A%()[,E%]) ; ; This MUST have at least one argument, A%(), which an integer array ; containing a directive parameter block in which A%(0) is the DIC ; code (see RSX-11M Executive Reference Manual), and its remaining elements ; are any parameters required. If E% is given, then on return it will contain ; a positive integer (usually 1) if the Executive call worked, and a negative ; one if it failed. ; ; NOTE ; ---- ; Whilst any Executive directive call may be initiated through these ; subroutines, by no means all are sensible for BASIC. It is the user's ; responsibility to only issue meaningful ones and to accept the ; consequences of doing anything silly. ; ; ; ; MCR ; --- ; 300 CALL "MCR"(C$,L%[,E%]) ; ; Because of the number of redundant arguments to the SPWN$ executive call, ; this is included as a special subroutine. C$ is the command line to be ; sent to MCR, and L% is its length (e.g. LEN(C$)). BASIC waits until the ; command has been executed (or rejected), and, if E% is given, returns in it ; the exit status of the spawned task (or MCR). If the spawn is rejected ; totally, then E% is the executive error code from the SPWN$ call. ; ; Example: ; 300 CALL "MCR"('PRINT PROG.LST',14%,E%) ; ; could be used to spool file PROG.LST to the lineprinter. ; ; DCL ; --- ; 400 CALL "DCL"(C$,L%[,E%]) ; ; As MCR, but the command goes to the Digital Command Language interpreter ; instead of MCR. ; ; CLI ; --- ; 500 CALL "CLI"(C$,L%[,E%]) ; ; As above, but the command is sent to the default command line interpreter ; for the terminal on RSX-11M/M-PLUS, always to MCR on VAX-11 RSX. ;- $LONGE=1 ; Long error messages LF=12 CR=15 .GLOBL ERRARG,$DSW .MCALL DIR$,SPWN$,QIOW$,WSIG$S,STSE$,WTSE$,ALTP$ HEADER GETADR,GETST GETST: MOV %5,%0 ; Copy argument pointer to preserve %5 MOV (%0)+,%1 ; Fetch first word = 202*400! DECB %1 ; Compare with 1 BLT ARGERR ; Must be at least 1 BEQ 30$ ; Nothing to do if exactly 1, don't complain MOV (%0)+,%2 ; %2 addresses the array TST (%2)+ ; Leave A%(0) alone 10$: MOV (%0)+,%3 ; Fetch next argument address CMP %3,#177777 ; If 177777, entry is blank BEQ 20$ ; Yes, go get next MOV %3,@%2 ; No, return address 20$: TST (%2)+ ; Advance array pointer DECB %1 ; Any more arguments? BGT 10$ ; Yes, go get next 30$: RTS PC ; No, all done, return to caller HEADER SYSTEM,SYSST SYSST: CMPB @%5,#2 ; Must be 2 arguments BNE ARGERR ; Error if not DIR$ 2(%5) ; OK, issue system call CMPB @%5,#2 ; Is there an E% argument? BLO 10$ ; No, don't return $DSW CMP 4(%5),#177777 ; Yes, make sure it's not a null argument BEQ 10$ ; when do nothing MOV $DSW,@4(%5) ; OK, return directive status 10$: RTS PC ; That's all ARGERR: JMP ERRARG ; Long jump to argument error handler HEADER MCR,MCRST HEADER DCL,DCLST HEADER CLI,CLIST .IF DF P$$OFF .PSECT SPWN: SPWN$ MCR...,,,,,$TLUN,, ; Spawn MCR..., event flag $TLUN .IF DF S$$TOP WAIT: STSE$ $TLUN ; Will stop during spawn if stop bits supported .IFF WAIT: WTSE$ $TLUN ; Wait if not, .IIF DF A$$PRI ALTP: ALTP$ ,10. ; reducing priority if possible .ENDC .PSECT SYSPAK,RO,I,LCL,CON .IFTF CLIST: MOV #^RCLI,%0 ; Use default CLI BR COMST ; Join common code DCLST: MOV #^RDCL,%0 ; Use DCL BR COMST MCRST: MOV #^RMCR,%0 ; Use MCR COMST: CMPB @%5,#2 ; Must have at least 2 arguments BLO ARGERR ; Error if less .IFF BEQ 10$ ; Exit if just 2 CMP 6(%5),#177777 ; Is 3rd a dummy? BEQ 10$ ; Yes, don't return anything to it MOV #IE.IFC,@6(%5) ; No, say invalid DIC = spawn not supported 10$: RTS PC ; Sorry .IFT MOV %0,SPWN+S.PWTN ; Set up required CLI's name MOV 2(%5),SPWN+S.PWCA ; Load command line address MOVB @4(%5),SPWN+S.PWCL ; and length SUB #16.,SP ; No, make an esb on the stack MOV SP,SPWN+S.PWES ; Load exit status word address MOV R5,-(SP) ; Save argument list pointer MOV @#$OTSV,R5 ; Load workspace MOV (R5),R5 ; pointer JSR PC,DTTCH ; Detach terminal while offspring runs 15$: DIR$ #SPWN ; Spawn task BCC 30$ ; Branch if spawn succeeds CMP $DSW,#IE.UPN ; Failed, no pool? BNE 20$ ; No, return any other error WSIG$S ; Yes, wait for something to happen BR 15$ ; and try again 20$: MOV $DSW,(SP) ; Failed, return error code BR 40$ ; to caller 30$: ; Spawn worked, wait for completion .IF DF ALTP ; Can't STOP, alter priority MOV #10.,ALTP+A.LTPR ; to 10. DIR$ #ALTP ; while offspring is running .ENDC DIR$ #WAIT ; Wait or stop for event flag .IF DF ALTP ; Priority was reduced, CLR ALTP+A.LTPR ; Clear word DIR$ #ALTP ; to reset to installed priority .ENDC ; Return exit status if we had a third argument 40$: CALL ATTCH ; Re-attach terminal MOV (SP)+,R5 ; Reload argument list pointer CMPB (%5),#3 ; >=3 arguments? BLO 50$ ; No, we definately don't CMP 6(%5),#177777 ; Yes, is 3rd a dummy? BEQ 50$ ; Yes, that means none too MOV (SP),@6(R5) ; We have one, put 1st word of esb into it 50$: ADD #16.,SP ; Purge stack RTS PC ; and return .ENDC .END