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.
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).
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,#<D.DDB+512> ; ?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 #<D.DDB/4>-1,Dtemp ; pre-clear the DDB
10$: CLR (DDB)+
DBF Dtemp,10$
; set DDB as INITed with prog handling errors, bypass messages
MOVW #<D$BYP!D$ERC!D$INI>_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 #<D$INI!D$ERC!D$BYP>_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
