OBJNAM XCALL.SBR ; Created 26-Oct-85, Last modified 15-Nov-85 IF EQ,1 Subroutine to indirectly xcall another XCALL subroutine, for use with AlphaBASIC under the AMOS/L operating system. by Irv Bromberg, Medic/OS Consultants, Toronto, CANADA This program is freely offered to the public domain. Under AMOS/L 1.2A(106) version 5.0(34) size=842 bytes, hash=313-622-055-762 Install the assembled .SBR file in DSK0:[7,6]. Since XCALL.SBR will probably be heavily used on your system if you apply it in the intended manner it is recommended that it also be installed in SYSTEM memory. Edit history: 3.3(27) 5-Nov-85 For X-var load clear SBR'Header if SBR not re-usable 3.4(28) 5-Nov-85 For PHDR check allow -2 as well as -1 3.5(29) 5-Nov-85 Trap for insufficient user privileges 4.0(30) 6-Nov-85 Added soft error signalling capability 4.1(31) 6-Nov-85 Added CRLF at end of hard error messages 4.2(32) 14-Nov-85 Changed address errmsg (any MAP level allowed if even addr) 4.3(33) 14-Nov-85 Can't do X-var load if area for program less than 512 bytes Can't do BASIC workspace load if less than 512 bytes free 5.0(34) 15-Nov-85 Delete 512-byte minimum restriction by doing the ABS fetch ourselves instead of letting AMOS do it (also faster since we save repeating the lookup). ENDC RADIX 10 ; think "DECIMAL" VEDIT=34 ; Note version number! If you have a previous version VMINOR=0 ; of XCALL.SBR then discard it and use this revised VMAJOR=5 ; version! VSUB=0 IF EQ,1 XCALL.SBR see XCALL.DOC (printable documentation) for more info This subroutine executes an indirect XCALL to a specified XCALL subroutine. Calling syntax: XCALL XCALL {,Err'Code} ,PROGRAM {,Param1,Param2...} where PROGRAM can be either any AlphaBASIC string expression specifying the name of the XCALL subroutine to be executed OR can be a variable of Unformatted type whose format is as described below, and Err'Code is an optional variable of type Floating which can be used as a soft error signal (default is hard error signal by display of error message and signal ^C Operator Interrupt to BASIC). The search path taken is the same as for a normal XCALL -- search SYSTEM/user memory first, then user's logged-in [p,pn], then [p,0], then DSK0:[7,6]. If the SBR is found in memory it is executed in place and none of the free BASIC workspace is consumed (although D.DDB+512 bytes are temporarily required as a DDB+buffer). Otherwise it is loaded as an absolute overlay into the user's free BASIC workspace and register A4 is adjusted to point just past the loaded subroutine. In the case where PROGRAM is an unformatted variable it can be mapped as follows: map1 SBR ! MAP1 level ensures EVEN memory address map2 REQNAM,S,6 ! name of the requested subroutine map2 SBR'Header ! subroutine header info used by XCALL.SBR map3 ASCNAM,S,6 ! ASCII name of SBR contained herein map3 SBRNAM,S,4 ! RAD50-packed subroutine name - DO NOT MODIFY map3 SBRLEN,B,2 ! length of loaded subroutine, if any map2 PROG,X,nnnn ! where nnnn=desired size to hold loaded program Then pass the mapped variable to XCALL.SBR as follows: REQNAM="gork" ! substitute "gork" with desired subroutine name XCALL XCALL,SBR {,Param1 {,Param2....}} When XCALL.SBR finds that its first parameter is Unformatted it will fetch the requested subroutine into the variable (if it is not already there) provided that the subroutine was not found in User or SYSTEM memory and that there is sufficient space in the variable to load the entire subroutine. If there is insufficient space then XCALL.SBR will try to load the subroutine into the BASIC free space instead, without modifying the SBR'Header. If there IS sufficient space but the FETCH operation fails then the SBR'Header will be completely cleared and then the "?Cannot load..." error condition will be signalled. When a new subroutine is successfully loaded into PROG the contents of REQNAM are copied to ASCNAM (without case conversion). This is unlikely to be of any use to an application program but can be checked for trouble- shooting purposes. The user may if desired omit the full map like this: map1 PROG,X,nnnn ! set nnnn=desired size to hold program + header info PROG="gork " ! important to right-pad to exactly 6 characters ! else cannot guarantee name processed properly XCALL XCALL {,Err'Code} ,PROG {,Param1 {,Param2...}} but in this case it will not be possible to check whether the subroutine was loaded into the variable or executed elsewhere (who cares anyway?). The unformatted variable method has the effect of a simple cache system for XCALL subroutine loading. The requested XCALL subroutine is NOT re-loaded if it is already in the variable or in User or SYSTEM memory, and any subroutine already there is not clobbered when a newly requested one will not fit. The warning DO NOT MODIFY the SBRNAM parameter (RAD50 name) is to prevent accidents -- you can clear this parameter (SBRNAM="") to force re-loading the next time XCALL is called, but it is unlikely that you would ever intentionally want to do so. Any other change to SBRNAM could confuse XCALL.SBR because it will think it has a different subroutine loaded than the one it actually has. One more point: if the SBR loaded into the X-variable does not have a standard Alpha Micro program header OR if the PH$REU (re-useable) characteristic flag is not set then the SBR is treated as non-reusable -- the SBR'Header area will be cleared to prevent the same copy from being re-used, and then the SBR will be executed. The argument list (@A3) is adjusted so that the list of arguments passed to XCALL.SBR is seen in the proper format as an argument list by the requested subroutine. The free workspace pointer (A4) is adjusted to point just past the loaded subroutine only in the case where the subroutine had to be loaded (temporarily) into this area. Possible hard error messages (also accompanied by CTRLC ?Operator interrupt) include: ?Out of memory in XCALL.SBR ?Subroutine not found in XCALL.SBR ?Cannot load subroutine in XCALL.SBR (absolute FETCH operation failed) ?Address error - X variable must be at EVEN memory address in XCALL.SBR ?Insufficient privileges to run subroutine in XCALL.SBR When the optional floating Err'Code parameter is passed then it will be zero after a successful call but after an unsuccessful call it will contain the ASCII number of the first character of the error message that would have been displayed if hard error signalling was being used. This can optionally be converted to sequential numbers using the following BASIC expression (as an example): Error'Number=INSTR(1,"OSCAI",CHR$(Err'Code)) which leaves a value of zero in Error'Number if there was no error. There is no restriction on nested calls to XCALL.SBR (to any depth), thus for example XCALL XCALL,"xcall","xCALL","xCall",PRGNAM,... is totally valid, albeit strange. XCALL.SBR checks whether the subroutine being called is named "XCALL" and if so does not load itself again, therefore nested xcall levels do not consume more free workspace (provided that you do NOT rename XCALL.SBR and invoke the renamed copy). Since XCALL.SBR is fully re-entrant and re-useable it can be loaded into SYSTEM memory (recommended for fastest performance). ENDC SEARCH SYS SEARCH SYSSYM Impure=A0 DDB=A1 Buffer=A2 SBR=A2 ArgBas=A3 Worksp=A4 Stack=A5 Atemp=A6 ErrCode=A6 JCB=A6 Pcount=D0 Char=D1 Number=D1 Last=D1 ; bytes used in last block Size=D2 Free=D3 SavTwo=D3 ; used in LoadIt routine to save two bytes Flags=D4 ; the following are bit numbers in Flags register XLOAD=0 ; set if we are attempting an X-variable SBR load SOFT=1 ; set if we are using soft error signalling BlkCnt=D5 Dtemp=D6 Ptype=D6 ASECT .=D.WRK ; format of D.WRK(DDB) after LOOKUP operation Blocks: BLKL 1 ; blocks used by the file Active: BLKL 1 ; bytes active in last block First: BLKL 1 ; first block# .=0 ; format of unformatted variable containing an XCALL subroutine: REQNAM: BLKB 6 ; ASCII name of XCALL subroutine to invoke ASCNAM: BLKB 6 ; ASCNAM name of SBR actually contained in variable SBRNAM: BLKL 1 ; RAD50-packed name of subroutine in variable SBRLEN: BLKW 1 ; length of subroutine in variable HDRSIZ=. ; size of the header area Prog: ; the subroutine itself follows .=0 PSECT PRGBAS: PHDR -1,0,PH$REE!PH$REU CLR Flags ; pre-clear all special flags MOVW @ArgBas,Pcount ; must have at least 1 arg =sbr name JEQ NotFound MOVW 2(ArgBas),Ptype ; get 1st parameter type CMPB Ptype,#4 ; soft error signal desired? BNE ChkX DECW Pcount ; required to adjust Arglst later MOV 4(ArgBas),ErrCode ; was Err'Code passed by value? CMP ErrCode,Stack BHIS Skip ; yes, must ignore & do hard signal BSET #SOFT,Flags ; remember we're doing soft errors CLRB (ErrCode)+ ; pre-clear Err'Code=0 CLRB (ErrCode)+ CLRB (ErrCode)+ CLRB (ErrCode)+ CLRB (ErrCode)+ CLRB (ErrCode)+ Skip: ADD #10,ArgBas ; skip by it MOVW 2(ArgBas),Ptype ; get next parameter type ChkX: TSTB Ptype ; 0=unformatted variable BNE CalcFree BSET #XLOAD,Flags ; remember we're doing X-var load CalcFree:MOV Stack,Free ; calculate free space available SUB Worksp,Free InitDDB:CMP Free,# ; ?enough room for DDB & buffer JLO NoMem ; set DDB as INITed with prog handling errors, bypass messages MOV Worksp,DDB ; temporary copy for clear MOVW #-1,Dtemp ; pre-clear the DDB 10$: CLR (DDB)+ DBF Dtemp,10$ ; set DDB as INITed with prog handling errors, bypass messages MOVW #_8,@Worksp ; set already inited MOVW #-1,D.DRV(Worksp) ; use default drive# MOV #512,D.SIZ(Worksp) ; 512-byte buffer size LEA Atemp,D.DDB(Worksp) ; put buffer after DDB MOV Atemp,D.BUF(Worksp) ; init buffer GetName:MOV 4(ArgBas),Buffer ; index the subroutine name MOV 8(ArgBas),Size ; get the size of the name parameter SUB #8,SP ; get some workspace MOV SP,Atemp CMPW Size,#6 ; take maximum of 6-byte file name BLO 20$ ; if <6 then OK, enter at end of DBcc MOVW #6-1,Size ; pre-decrement for DBcc loop 10$: MOVB (Buffer)+,(Atemp)+ ; Copy filename to workspace where 20$: DBEQ Size,10$ ; we can make sure it has a terminating CLRB (Atemp) ; NULL. MOV SP,Buffer ; FILNAM needs addr in A2 PackName:FILNAM D.FIL(Worksp),SBR ; get the SBR name, default ext=SBR ADD #8,SP ; return the workspace taken JEQ NotFound ; illegal file name CMP D.FIL(Worksp),#<[XCA]_16+[LL ]> ; nested XCALL XCALL? BNE ChkTyp LEA SBR,PRGBAS ; yes, don't re-load it! --> go! JMP Setup ChkTyp: BTST #XLOAD,Flags ; is PROGRAM an unformatted variable? BEQ Search ; no, go to normal search routine MOV 4(ArgBas),SBR ; yes, check if contents match MOV SBR,Dtemp ; check for address error BTST #0,Dtemp JNE Addr ; odd, trap it - we need EVEN addr MOV SBRNAM(SBR),Dtemp ; same name? BEQ Search ; 0=nothing loaded yet CMP Dtemp,D.FIL(Worksp) BNE Search LEA SBR,Prog(SBR) ; name matches, off we go JMP Setup ; jumping into the variable! Search: SRCH D.FIL(Worksp),SBR ; search user/system memory JEQ Setup ; not found in user/system memory, now do standard xcall disk search for it DSKSCH: JOBIDX ; get JCB MOVW JOBUSR(JCB),D.PPN(Worksp) ; search user [p,pn] first LOOKUP @Worksp BEQ Found CLRB D.PPN(Worksp) ; now try [p,0] LOOKUP @Worksp BEQ Found CLR D.DVR(Worksp) ; now try DSK0:[7,6] MOVW #[DSK],D.DEV(Worksp) CLRW D.DRV(Worksp) MOVW #<7_8+6>,D.PPN(Worksp) LOOKUP @Worksp JNE NotFound Found: ; check for sufficient memory to load the subroutine MOV Blocks(Worksp),BlkCnt ; get #blocks we have to fetch MOV Active(Worksp),Last ; get #bytes active in last block MOV BlkCnt,Size ; calculate size of XCALL routine DEC Size ; less one for last rec MUL Size,#510 ; 510 bytes used per sequential record ADD Last,Size ; add #bytes active in last rec SUB #2,Size ; less 2 for link bytes in last rec BTST #0,Size ; if size is ODD make it EVEN (higher) BEQ ABSFCH INC Size ABSFCH: ; now fetch the subroutine as an absolute memory overlay @Worksp JOBIDX ; use JOBRBK as temporary DDB for LEA DDB,JOBRBK(JCB) ; absolute FETCH so no memory wasted MOV Worksp,SBR ; default load into BASIC workspace BTST #XLOAD,Flags ; load into X-var (if room)? BEQ ChkFree ; no, it's a string, name only MOV 8(ArgBas),Dtemp ; get size of X-var SUB #HDRSIZ,Dtemp ; adjust for header area CMP Size,Dtemp ; is there room for it in X-var? BHI ChkFree ; no, try to load into free space XVFCH: ; yes! there is enough room to load it into X-var, get ready MOV 4(ArgBas),Atemp ; index the X-var LEA SBR,ASCNAM(Atemp) ; index the SBR'Header MOV (Atemp)+,(SBR)+ ; copy the ASCII name MOVW (Atemp)+,(SBR)+ MOV D.FIL(Worksp),(SBR)+ ; update RAD50 SBRNAM MOVW Size,(SBR)+ ; update SBRLEN BR LoadIt ; go load it in! ChkFree:BCLR #XLOAD,Flags ; forget it if var was unformatted! CMP Free,Size ; calculate if there is enough JLOS NoMem ; if <=0 there is not enough memory LoadIt: MOVW D.DEV(Worksp),D.DEV(DDB); copy device name MOV D.DRV(Worksp),D.DRV(DDB); copy drive number ; Don't need to copy file name/extension because physical block# ; is all we need to know and we already know it from LOOKUP PUSH First(Worksp) ; save first phyrec# before INIT MOVW #_8,@DDB MOV SBR,D.BUF(DDB) ; flag buffer as already inited INIT @DDB ; INIT the DDB (except buffer) ; There is a very good reason why we do the absolute fetch the hard way ; (ourselves) instead of letting AMOS do it: AMOS will waste time repeating ; the LOOKUP to get the physical block number which we already know from ; our LOOKUP, and in so doing AMOS requires 512 bytes as a UFD buffer for the ; lookup which could affect memory that is outside target load area (e.g. ; if mapped part of X-variable beyond header area is less than 512 bytes). MOV D.DVR(DDB),Atemp ; get disk driver's address MOV @Atemp,D.SIZ(DDB) ; copy phyrec size POP D.REC(DDB) ; recall first phyrec# PUSH SBR ; save ptr to start of SBR NxtBlk: SUB #2,SBR ; handle link to next block MOV SBR,D.BUF(DDB) ; set address for next block MOVW @SBR,SavTwo ; save two bytes that we'll clobber DEC BlkCnt ; decrement block counter BEQ LastBlk ; only last block left READ @DDB ; phyread MOVW @SBR,D.REC+2(DDB) ; set next block# MOVW SavTwo,@SBR ; restore clobbered bytes ADD D.SIZ(DDB),SBR ; point past loaded part BR NxtBlk ; back for more until last is last LastBlk:MOV Last,D.SIZ(DDB) ; only read #bytes in last block READ @DDB ; so we don't clobber data beyond MOVW SavTwo,@SBR ; restore clobbered bytes POP SBR ; FETCH all done, restore ptr to start BTST #XLOAD,Flags ; was it a load to X-var? BNE ChkHdr ; yes, check the program header LEA Worksp,0(SBR)[Size] ; and adjust A4 = new free workspace BR Setup ChkHdr: CMPW PH.FLG(SBR),#^H0FFFE ; do we have a program header? BLO NoReUse ; no, cannot re-use this program MOVW PH.CHR(SBR),Dtemp ; is PH$REU flag set? (re-usable) ANDW #PH$REU,Dtemp BNE Setup ; yes, OK to re-use NoReUse:MOV SBR,Dtemp ; save SBR pointer CLR -(SBR) ; clear the SBR'Header area CLR -(SBR) ; so we won't re-use this one CLR -(SBR) MOV Dtemp,SBR ; restore SBR pointer Setup: ; set up new argument list for called XCALL ADD #10,ArgBas ; skip prgnam parameter DECW Pcount MOVW Pcount,@ArgBas ; set new param count (less 1) CMPW PH.FLG(SBR),#^H0FFFE ; PHDR present? BHIS ChkPrv ; yes, check privileges JMP @SBR ; no, jump to XCALL routine, RTN from there to BASIC ChkPrv: ; does the user have sufficient privileges to run this subroutine? JOBIDX MOVW JOBPRV(JCB),Dtemp COMW Dtemp ANDW PH.PRV(SBR),Dtemp BNE Priv ; no, insufficient privileges JMP PH.SIZ(SBR) ; yes, jump beyond program header ; Error messages follow: Priv: LEA Atemp,Ierr ; insufficient privileges BR Error Addr: LEA Atemp,Aerr ; address error BR Error Cannot: LEA Atemp,Cerr ; cannot load BTST #XLOAD,Flags ; was it an X-var load? BEQ Error ; no CLR -(SBR) ; yes, clear the SBR'Header area CLR -(SBR) CLR -(SBR) BR Error NoMem: LEA Atemp,Oerr ; out of memory BR Error NotFound:LEA Atemp,Serr ; subroutine not found Error: BTST #SOFT,Flags ; signalling soft errors? BEQ Hard ; no, output hard error signal CLR Number ; pre-clear for byte move MOVB 1(Atemp),Number ; get starting error code letter SUB #8,SP ; get some workspace for FLTOF MOV SP,Worksp FLTOF Number,@Worksp ; convert to floating format MOV -6(ArgBas),ErrCode ; get address of floating parameter MOVB (Worksp)+,(ErrCode)+ ; move byte-by-byte to avoid address MOVB (Worksp)+,(ErrCode)+ ; error MOVB (Worksp)+,(ErrCode)+ MOVB (Worksp)+,(ErrCode)+ MOVB (Worksp)+,(ErrCode)+ MOVB (Worksp)+,(ErrCode)+ ADD #8,SP ; release temporary workspace RTN ; return to BASIC Hard: TTYL ; output the error message TYPECR < in XCALL.SBR> ; followed by " in XCALL.SBR" JOBIDX ; and we set pending Control-C flag ORW #J.CCC,JOBSTS(JCB) ; in JCB to cause ?Operator Interrupt RTN ; error signal to BASIC. Ierr: ASCIZ "?Insufficient privileges to run subroutine" Aerr: ASCIZ "?Address error - X variable must be at EVEN memory address" Cerr: ASCIZ "?Cannot load subroutine" Oerr: ASCIZ "?Out of memory" Serr: ASCIZ "?Subroutine not found" EVEN END .