Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
COMMENT VALID 00052 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00005 00002 HISTORY
C00013 00003 DATA for Total (Low-level Code Production) Routines
C00016 00004 Description of Total Routines
C00026 00005 CONV, PRE, POST -- Type-Conversion routines
C00032 00006
C00036 00007
C00043 00008
C00045 00009 PUT
C00049 00010 ACCESS,GETSDR,GETDR,DISBLK,ZOTDIS--last four only for dis
C00059 00011 GET
C00066 00012
C00069 00013
C00073 00014
C00079 00015 STACK -- Issue Instrs. to Stack Anything on Approp. Stack
C00084 00016 MARK, MARKINT, MARKME -- Mark Semblk with Correct Temp Semantics
C00088 00017 INCOR -- Issue Code to Clear this Entity from ACs
C00089 00018 REMOPs, CLEARs -- Remove Temps, ACs, from Use
C00101 00019 DSCR CLEAR,CLEARL,CLEARA
C00104 00020 STROP -- Bit-Driven String Operation Code Generator
C00111 00021 GETTEM, etc. -- Temp Semblk Allocators
C00115 00022 GETAC, GETAN0 -- AC Allocators
C00121 00023 AC Store routines -- BOLSTO, FORSTO, STORIX, GOSTO, STORZ
C00126 00024 STORA -- main AC-storing subr. -- called by above
C00133 00025 EMITER -- Descriptions of Routine and Control Bits
C00136 00026 EMITER Routine
C00140 00027
C00146 00028 SUBI TEMP,1 FIX IT
C00152 00029
C00155 00030 Qstack Routines -- BPUSH, etc.
C00159 00031
C00162 00032
C00165 00033 PWR2
C00166 00034 GBOUT Description, Loader Block Format Description
C00169 00035 Control Variables for Loader Block Output
C00172 00036 Loader Output Blocks-- Entry, Program Name, Initial Stuff
C00176 00037 Code, Boolean Code, Fixups, Links
C00180 00038 Space Allocation Block
C00184 00039 Request Blocks -- RELfile, Libraries
C00186 00040 Ending Code, Symbols -- END Block
C00190 00041 RELINI -- Loader Block Initialization
C00191 00042 GBOUT Routine
C00194 00043 CODOUT Routine -- Output Code or Data
C00198 00044
C00199 00045 FBOUT, etc. -- Output Fixups
C00202 00046 SCOUT, etc. -- Output Symbols
C00206 00047 LNKOUT -- Output Linkage Block
C00208 00048 PRGOUT, FILSCN -- Output Request Blocks, Scan for Source!file Rqst
C00218 00049
C00221 00050 >NOTENX
C00223 00051 RAD50, RAD52 -- Radix-50 Functions for Scout Routines
C00227 00052
C00228 ENDMK
C;
COMMENT HISTORY
AUTHOR,REASON
021 102100000044 ;
COMMENT
VERSION 17-1(36) 3-7-75 BY RHT BUG #UE# STRING ARRAY ISNT A STRING
VERSION 17-1(35) 2-16-75 BY JFR BAIL P.35 DEFINE RESIDENCE OF RUNTIME PROCEDURE DESCRIPTORS
VERSION 17-1(34) 12-7-74 BY JFR DEFINE RESIDENCE OF BAIL LOADMODULE
VERSION 17-1(33) 11-3-74 BY RHT BUG TR MAKE GBOUT HONEST ABOUT WORD COUNT
VERSION 17-1(32) 10-10-74 BY RHT FEAT %BR% (REMOVE HACKS)
VERSION 17-1(31) 7-24-74 BY RHT BUG #SV# GET SPAC OF RECORD WAS LOSING
VERSION 17-1(30) 7-22-74 BY RHT BUG #SU# CONV(ARITH) FOR PNTVAR
VERSION 17-1(29) 7-7-74 BY RHT MANY EDITS FOR RECGC
VERSION 17-1(28) 7-7-74
VERSION 17-1(27) 7-7-74
VERSION 17-1(26) 7-7-74
VERSION 17-1(25) 5-30-74 BY RLS TENEX BUG #SK# DONT MESS UP DEVICE NAME FOR LOAD!MODULE
VERSION 17-1(24) 5-20-74 BY RHT BUG #SA# SHOULD NOT BUMP REF CNT ON GET ADDR
VERSION 17-1(23) 5-14-74 BY RHT BUG #RY# RECUUO (AC) S/B RECUUO 0,AC
VERSION 17-1(22) 4-18-74
VERSION 17-1(21) 4-12-74 BY RHT %BI% MAKE EMITTER KNOW ABOUT RECORD CLASSES
VERSION 17-1(20) 4-12-74 BY RHT %BI% ADD SOME LOW LEVEL RECORD STUFF
VERSION 17-1(19) 4-12-74
VERSION 17-1(18) 4-12-74
VERSION 17-1(17) 4-12-74
VERSION 17-1(16) 4-12-74
VERSION 17-1(15) 4-12-74
VERSION 17-1(14) 4-6-74 BY RLS TENEX
VERSION 17-1(13) 3-17-74 BY RLS TENEX ADDITIONS
VERSION 17-1(13) 2-13-74 BY JRL BUG #RE# STRING ITEMVAR ARRAY NOT STRING ARRAY
VERSION 17-1(12) 1-11-74 BY JRL CMU CHANGE COMVER (UNDER NOHACK)
VERSION 17-1(11) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(10) 11-24-73 BY RHT %AL% TAKE HRLOI 12, OUT OF S. SEQUENCE
VERSION 17-1(9) 11-24-73 BY RFS RADIX50 TYPE BITS NOT INSTALLED IN RAD5$, RAD5%
VERSION 17-1(8) 11-13-73 BY JRL FORCE PUT TO ALWAYS DO AN ACCESS
VERSION 17-1(7) 11-13-73 BY JRL BUG #PA# GET ADDR OF MPPARM WAS DESTROYING AC C
VERSION 17-1(6) 11-13-73 BY JRL BUG #OZ# FIX GET FOR INSISTED ITEMVARS
VERSION 17-1(5) 11-4-73 BY JRL BUG #OX# LET PUT KNOW ABOUT ? ITEMVARS
VERSION 17-1(4) 10-26-73 BY JRL BUG #OR# A STRING ITEM IS NOT A STRING
VERSION 17-1(3) 10-23-73 BY JRL FEATURE %AG& ITEM OVERLAP STUFF
VERSION 17-1(2) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSW
VERSION 17-1(1) 8-2-73 BY JRL BUG #NK# TEMPS SHOULD NOT HAVE DISPLAY LEVELS
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION IS 17 ****
VERSION 16-2(31) 7-13-73 BY RHT MODIFY SOUT FOR FNYNAM
VERSION 16-2(30) 7-13-73 BY RHT BUG #MN# A DREADFUL KLUGE TO FIX ACCESS BUG
VERSION 16-2(29) 7-13-73
VERSION 16-2(28) 6-28-73 BY JRL BUG #KA#B IMMEDIATE INSTRUCTIONS NOT USED FOR OR,AND
VERSION 16-2(27) 3-19-73 BY RHT CHANGE SOUT SO STACK SYMBOLS WORK RIGHT
VERSION 16-2(26) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
VERSION 16-2(25) 2-26-73 BY JRL DO A SKIPE NOEMIT IN XCALLQ
VERSION 16-2(24) 2-6-73 BY JRL MAKE GET HONEST FOR QPARS
VERSION 16-2(23) 1-31-73 BY HJS DISABLE CODOUT, EMITER, AND FBOUT FOR EXPR!TYPE
VERSION 16-2(22) 12-13-72 BY JRL BUG #KS# ADD LOADVR SWITCH
VERSION 16-2(21) 12-13-72
VERSION 16-2(20) 11-30-72 BY JRL MAKE GET HONEST FOR ? ITEMVARS
VERSION 16-2(19) 11-30-72 BY JRL BUG #KQ# IGNORE FIXARRS IN STORA
VERSION 16-2(18) 11-21-72 BY RHT BUG #KH# DEL FORMFX STUFF FROM SIMPROC FORMALS
VERSION 16-2(17) 10-17-72 BY JRL BUG #JR# STRING ITEMVARS NOT STRING
VERSION 16-2(16) 8-29-72 BY KVL ADD CKECK FOR UNTYPED IN PRE
VERSION 16-2(15) 7-17-72 BY RHT BUG #IO# EVAR MESSED UP BY INDEXED STRING TEMP
VERSION 16-2(14) 7-8-72 BY RHT BUG ##I#L# GET ACCESS TO A VARIABLE IN PRE BEFORE INSISTING
VERSION 16-2(13) 6-30-72 BY DCS BUG #IA# PROTECT PTRAC AC OVER FIX, FLOAT, STRING to INTEGER
VERSION 16-2(12) 6-25-72 BY DCS BUG #HX# PARAMETERIZE LIBRARY NAMES (OTHER THINGS)
VERSION 16-2(11) 6-20-72 BY DCS BUG #HU# BETTER TTY PRINTOUT
VERSION 16-2(10) 6-14-72 BY JRL BUG #HS# AN ITEMVAR IS NOT ITS DATUM(MARK).
VERSION 16-2(9) 5-13-72 BY DCS BUG #HF# MAKE GETAC MUCH MORE HONEST
VERSION 15-2(8) 3-25-72 BY DCS BAD ARRAY ADDRESS PROBLEM
VERSION 15-2(7) 3-10-72 BY DCS REPLACE RING, ULINK MACROS WITH ROUTINES
VERSION 15-2(6) 2-9-72 BY DCS BUG #GQ# MAKE ! = UNDERLINE IN RADIX50
VERSION 15-2(5) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
VERSION 15-2(4) 2-1-72 BY DCS ISSUE %ALLOC SPACE REQUESTS IN NEW WAY (SEE GOGOL FOR FORMAT)
VERSION 15-2(3) 1-10-72 BY DCS BUG #FP# FIX A NEGAT BUG
VERSION 15-2(2) 1-7-72 BY DCS BUG #FY# Fix Strvar_INAC-Intvar bookkeeping problem
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
;
COMMENT DATA for Total (Low-level Code Production) Routines
LSTON (TOTAL)
SUBTTL WIZARD'S DEN -- Generator Called Routines.
BEGIN TOTAL
ZERODATA (TOTAL ROUTINE VARIABLES)
;ACKPNT -- next AC # GETAC should try -- used to distribute
; AC usages among the ACs -- used by GETAC only
?ACKPNT: 0
COMMENT
FORMFX -- QSTACK descriptor for formal fixups. Until a recursive
Procedure has been completely compiled, it is not known how
many local strings and non-strings will be saved in the runtime
stacks between the stack tops and the formal parameters. Therefore
as instructions accessing parameters are issued, the address
field displacements (assuming 0 locals) are saved, along with
the addresses where they are issued, in the FORMFX stack.
The left half of each entry is the address of the instruction--
the right half is the desired relative displacement (high-order
bit specifies String stack or System stack). After the procedure
is compiled, these entries are QPOPed off and used, along with
the ALOCALS, SLOCALS counts (see PROCED variables) to issue
fixups for these instructions. This Qstack is not used
for non-recursive Procedures
^^FORMFX: 0
?POSSIB: 0 ;TEMP USED BY GETAC WHEN GETTING 2
;TEMPNO -- each temp Semblk allocated is assigned a unique
; number, by incrementing TEMPNO -- a temp Semblk may
; be used several times in the same procedure. See GETTEM
; for description of the mysteries of temps.
?TEMPNO: 0
ENDDATA
COMMENT Description of Total Routines
DSCR CONV,ACCESS,GET,PUT,STACK,MARK
DES This is the generalized move code. (i.e. called by macro GENMOV).
It consists of several routines which are called in a uniform
fashion. This fashion stipulates that "directive" bits be passed
in the right half of FF which specify modifiers on the operation
of the routine called. Each routine is preceded by a standard
preamble (PRE) and followed by a standard epilog (POST).
Some of the directive bits control PRE and POST. They are:
PAR
PRE:
1. If the GETD bit is on, we do a GETAD first (i.e. use PNT
as the pointer to a symbol table entry, and fill TBITS
and SBITS. This is useful since many of the GENMOV routines
require that TBITS and SBITS be set up.
2. If the PROTECT bit is set, then register D is assumed to have
an accumulator number in it. That accumulator table entry
is "protected". I.e. calls on GETAC and STORA will not affect
the status of anything marked in that accumulator.
3. If the EXCHIN bit is set, we do an EXCHOP.
4. If the INSIST bit is on, type conversions are performed.
These conversions convert from the type specified in the
TBITS word to the type specified in register B (bits
passed to the INSISTer).
5. If the ARITH bit is on, we make sure that the type is
an arithmetic type, performing conversions if necessary.
POST:
1. Put the current contents of the ac's TBITS and SBITS
down in the symbol table entry pointed to by PNT
2. If the REM bit is set, do a REMOP on the thing in PNT
3. If the BITS2 bit is set, we execute MOVE SBITS2,$SBITS(PNT2)
This is useful when an operation on one argument of a binary
op. may change the semantics of another.
4. If the UNPROTECT bit is set, then register D is assumed to
contain an ac number. The ac table entry is unprotected.
5. If the EXCHOUT bit is set, we do an EXCHOP.
NOW FOR A DESCRIPTION OF THE ROUTINES WHICH ACTUALLY USE PRE AND POST:
CONV:
This is really a no-op. It is here for the purposes of calling
the type-conversion routines in PRE, and for the purpose of
making sure that an argument is positive if in an accumulator
(e.g. if we had CVF(-(A+B)), then the result would be in an
accumulator in negated fashion. We now want to push it onto the
stack for the call on CVF. We want to make sure it is REAL and
positive. We use the POSIT bit: GENMOV (CONV,INSIST!POSIT,REAL)
PUT
This issues a store of accumulator mentioned in register D
into the thing described in TBITS, SBITS, PNT. The accumulator
table is updated to reflect this store (i.e. the thing talked about
by PNT is marked as "inac").
If the PNT entry is a string, then D is assumed to be an ac.
into which a HRROI was done, or the SP stack. At any rate, two
POP's are emitted.
ACCESS:
This routine makes sure that we can have access to the entry
mentioned in PNT. That is, if the thing is indexed (result of
an array calculation) and if it requires that some index accumulator
be loaded with a good number, then the load will happen, so
that an effective address can be generated which points at
the thing talked about by PNT.
GET:
This is the generalized "get this entity in an ac" routine.
It makes many checks (i.e. is it already in an ac?) and
finally returns in register D the number of the ac which
has been loaded, and returns in SBITS the updated semantics
information that now reflects the loaded state.
(By the way, to "get" a string means to do HRROI ac,second word
of string.. This is so that POP's can be done later). There
are many modifier bits to this routine:
DBL -- make sure that the ac following the one loaded
is free (for a double ac operation such as IDIV)
INDX -- make sure entity is loaded in an AC which can be
used for indexing (i.e. not 0 or 1. The reason
for including 1 in this is a bit vague -- since
runtime routines often return results in 1, we
try to avoid its use for things thay may have
to be stored as temps).
SPAC -- load this into a special accumulator. That accumulator
number is passed in D.
ADDR -- load the address of this entity, not the value.
POSIT -- make sure the entity is in the ac in positive form.
NEGAT -- make sure in negative form.
NONSTD -- if indxed temp, do not remop it as someone wants
to use it again. (see SWPR for instance). The
problem is not so much remopping, but that GET
likes to make the semantic entries as "inac" on
exit. This fouls up any index calculations that
may have been stored in the PNT entity.
MRK -- when done with the GET, call MARK (see below).
STACK:
The entity mentioned in PNT is stacked on an appropriate
stack. Strings (except arrays) are stacked on the SP
stack, all others on the P stack. ADEPTH or SDEPTH is
updated.
MARK:
This uses the bits in TBITS and SBITS, and the ac number
in D as prototypes for making up a temp descriptor, and
marking the ac full with that temp. Return is a valid
temp descriptor in PNT. If STRING is on in TBITS,
a stacked-string descriptor will be generated
(and of course, no accumulator will be marked).
WARNING ***** MARK masks off some bits in SBITS and
TBITS. PTRAC,CORTMP,INDXED,FIXARR are turned off in SBITS
and the only bits honored by TBITS are:
LPARRAY,SET,ITEM,ITMVAR,INTEGR,FLOTNG,STRING
SID
ACCUMULATORS:
FF -- RIGHT HALF SAVED.
A --THIS MAY BE CHANGED
B --SAVED, I BELIEVE.
C --SAVED, I BELIEVE.
D --OCCASIONALLY FILLED UP (E.G. GET,ACCESS)
TBITS -- THESE ARE THE SEMANTIC BITS -- THEY MAY BE CHANGED.
SBITS -- "
PNT -- " (IN CASE OF MARK OR CONVERSIONS)
LPSA CLOBBERED
USER CLOBBERED
TEMP CLOBBERED
SP --SAVED
SBITS2 --SAVED (modulo what is done in PRE).
TBITS2 --SAVED
PNT2 --SAVED
SEE GENMOV MACRO
;
COMMENT CONV, PRE, POST -- Type-Conversion routines
MASK__ 0+LPARRAY+SET+LSTBIT+ITEM+ITMVAR+INTEGR+FLOTNG+STRING!DBLPRC
;GENMOVE KNOWS ABOUT THESE TYPES
REC <
MASK __ MASK+PNTVAR
>;REC
;THIS IS THE PREAMBLE FOR ALL OF THE ROUTINES WHICH
;USE DIRECTIVE BITS TO SPECIFY COERCIONS, EXCHOPS, ETC.
PREMASK __ GETD!EXCHIN!INSIST!ARITH!PROTECT
^^CONV: TRNE FF,PREMASK
PUSHJ P,PRE ;DO EVERYTHING HERE.
TLNE SBITS,NEGAT ;IF NOT NEGAT OR
TRNN FF,POSIT ;NOT NEED THINGS POSITIVE?
JRST POST ;ALL DONE.
JRST GETOPE ;DO THE GET.
PRE: TRNE FF,GETD ;DO A GETAD?
PUSHJ P,GETAD ;YES
TRNE FF,EXCHIN ;EXCHOP ON WAY IN?
JRST [EXCHOP ;YES
JRST .+1]
TRNE FF,PROTECT
JRST [HRROS ACKTAB(D) ;PROTECT THIS AC
TDNN TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
TRNN TBITS,DBLPRC
JRST .+1 ;THESE ARE NOT DOUBLE
MOVEI TEMP,(D)
CAIN TEMP,RF-1
ERR <DRYROT PRE>,1
CAIE TEMP,RF-1
HRROS ACKTAB+1(D) ;2ND AC OF LONG
JRST .+1]
TRNN FF,INSIST!ARITH ;ANY COERCIONS TO DO?
POPJ P, ;NO -- ALL DONE.
PUSHJ P,QTYPCK
;CHECK FOR UNTYPED AND TYPE IF NEC. (SEE ERRORS)
;#IL# 7-8-72 RHT ! GET ACCESS BEFORE YOU CONVERT
PUSHJ P,ACCOP ;GET ACCESS -- YOU MAY NEED IT
TRNE FF,ARITH ;WANT TO BE SURE OF ARITH ARG?
JRST AGET ;YES
LEPPRE: TRNN TBITS,ITEM!ITMVAR ;IF EITHER HAS ITEM BITS ON.
TRNE B,ITEM!ITMVAR ;ALL THESE ARE GOOD GUYS.
JRST [ ;.... ;KEEP GOING.
TRNE B,ITEM!ITMVAR
TRNN TBITS,ITEM!ITMVAR
ERR <ITEM TYPE MISMATCH >,1
POPJ P,] ;THIS IS ALL THE CHECKING!
TRNE B,SET ;A SET OR LIST DESIRED?
JRST [TRNN TBITS,SET ;IF NOT LIST OR A SET CAN'T BE DONE
ERR <TYPE CAN'T BE CONVERTED TO SET OR LIST>,1
TRNE B,LSTBIT ;IF WANTED LIST CAN RETURN
JRST MAKLST ;MAY HAVE TO COPY LIST.
TRNN TBITS,LSTBIT ;IF WANTED SET AND HAVE SET CAN RETURN
POPJ P,
JRST MAKEST] ;WILL HAVE TO CALL CVSET
;;#YQ# JFR 2-2-77 DO RCLASS CHECKING FOR ASSIGNMENT NOW
REC <
TRNE TBITS,PNTVAR ;IF RECORDS & INSISTING
TRNE TBITS,SHORT!ITEM!ITMVAR ;THEN BETTER BE SURE CLASSES MATCH
JRST LEPP.1 ;NOT THAT CASE, ANYHOW
PUSH P,PNT2 ;NOTE DON'T CHECK ITEMS
PUSH P,LPSA
HLRZ PNT2,$ACNO(PNT) ; THE CLASSID
SKIPN LPSA,RCLASS ;
;; MWK This message used to be "RCLASS=0 ON INSISTING GET"
ERR <ATTEMPT TO COERCE RECORD POINTER>,1
PUSHJ P,SUBFOK ;CHECK CLASS ID
ERR <CLASS DISAGREEMENT FOR RECORD COERCION>,1
TRNN FF,MRK ;ASKED FOR A MARK
SETZM RCLASS ;NO, ALWAYS CLEAR THIS OUT
POP P,LPSA
POP P,PNT2
LEPP.1:
>;REC
;;#YQ# ^
MOVEI TEMP,(TBITS) ;ALWAYS INSIST ON CORRECT PRECISION
XORI TEMP,(B)
TRNN TBITS,DBLPRC
TRNE B,DBLPRC
TRNN TEMP,DBLPRC ;ONE IS DBL. ARE BOTH?
SKIPA TEMP,TBITS ;BOTH ARE SAME PRECISON
JRST AGOTH ;DIFFERENT PRECISION. MUST CONVERT
MOVE USER,B ;COPY OFF.
AND TEMP,[XWD SBSCRP,MASK(ITEM!ITMVAR)]
ORCB USER,[XWD SBSCRP,MASK(ITEM!ITMVAR)]
TDNN TEMP,USER ;ARE ALL BITS IN B ON IN TBITS?
POPJ P, ;THEY MATCH !!
AGOTH:
PUSH P,FF
TRZ FF,-1NONSTD ;IN CASE ANY OTHER ROUTINES CALLED.
PUSH P,D
TRNE B,INTEGR+FLOTNG
JRST RESAR ;INSISTS ON ARITHMETIC TYPE
TRNE B,STRING
JRST RESSTR ;INSISTS ON STRING
ERR <IMPOSSIBLE TYPE COERCION>,1
JRST GEMGO ;GO ON ANYWAY
RESSTR: TRNN TBITS,INTEGR ;INSIST ON INTEGER ARGUMENT.
ERR <STRINGS OF NON-INTEGERS?>
TLNN TBITS,CNST ;CONSTANT?
JRST STR1 ;NO
EXCH SP,STPSAV ;GET A GOOD STACK POINTER.
MOVSS POVTAB+6 ;ENABLE FOR STRING PDLOV
PUSH P,$VAL(PNT)
PUSHJ P,PUTCH ;MAKE A STRING (SLOWLY)
POP SP,PNAME+1
POP SP,PNAME
EXCH SP,STPSAV ;AND RESTORE EVERYONE.
MOVSS POVTAB+6 ;RE-ENABLE FOR PARSE PDLOV
PUSHJ P,STRINS ;INSERT A STRING CONSTANT
;THIS DOES A GETAD.
JRST GEMGO ;ALL DONE
STR1: ;PREPARE TO STACK THE INTEGER
PUSHJ P,STACK1 ;DO THE STACK.
SOS ADEPTH ;SINCE THE RUNTIM ROUTINES ADJUST.
MOVEI TEMP,2
ADDM TEMP,SDEPTH ;INCREASE DUE TO CALL.
XCALL <PUTCH> ;FUNCTION CALL
MOVEI SBITS,0 ;START WITH CLEAN DYNAMIC SLATE
JRST TGO ;GO MAKE A TEMP.
;;#SU# ! ADD PNTVAR TO THIS LIST
AGET: TRNE TBITS,INTEGR+FLOTNG+PNTVAR ;IS IT ALREADY ARITHMETIC TYPE?
POPJ P, ;YES
PUSH P,FF
TRZ FF,-1NONSTD ; SAVE ALL THIS FOR OTHER
PUSH P,D ; EMBEDDED OPERATIONS
MOVEI B,INTEGR ;THIS FOR THE BENEFIT OF ARSTR.
RESAR: TRNE TBITS,STRING ;HERE TO GET ARITHMETIC RESULTS
JRST ARSTR ;CONVERT FROM STRING
TRNE TBITS,INTEGR+FLOTNG
JRST FIXFL
ERR <IMPOSSIBLE TYPE COERCION>,1
JRST TGO ;MAKE A TEMP FOR IT ANYWAY...
ARSTR: TLNE TBITS,CNST ;CONSTANT?
JRST STRCNS
;;#IA# 6-30-72 DCS (3-6) PROTECT PTRAC AC OVER GETAC
HRLI PNT,-1 ;FLAG, ASSUME PROTECTION
HRRZ TEMP,$ACNO(PNT) ;PTRAC AC #, IF ANY
TLNN SBITS,PTRAC ;NEED PROTECTION?
TLZA PNT,-1 ;NO, UNMARK
HRROS ACKTAB(TEMP) ;YES, PROTECT
;;#IA# (3-6)
PUSH P,B ;SAVE TYPE WORD
PUSHJ P,GETAN0 ;NON-0 AC NUMBER
JUMPGE PNT,.+3 ;NEED TO UNPROTECT?
;;#IA# 6-30-72 (4-6)
HRRZ TEMP,$ACNO(PNT) ;YES, DO
HRRZS ACKTAB(TEMP) ; IT
;;#IA# (4-6)
MOVE A,[HRRZ LNWORD] ;CALCULATE LENGTH TO THIS AC
PUSHJ P,STROP ;VIA STROP
HRL B,PCNT ;SAVE PC FOR FIXUP
HRLI C,0
EMIT (<JUMPE USADDR!NORLC>) ;0 IF STRING EMPTY
TLNE SBITS,STTEMP ;NO NEED TO COPY BP IF TEMP STRING
JRST [MOVE A,[ILDB BPWORD]
PUSHJ P,STROP ;SO DO ILDB DIRECTLY
JRST NOCOP] ;AND GET OUT
MOVE A,[MOVE BPWORD] ;GET COPY OF BP
PUSHJ P,STROP ;IN SAME AC
HRL C,D
EMIT (<ILDB USADDR!NORLC>) ;ILDB AC,AC
NOCOP: HRR B,PCNT ;FIXUP WORD
PUSHJ P,FBOUT
MOVEI A,UNDO!REM
PUSHJ P,STROP ;NOW ISSUE SUB IF NECESSARY
PUSHJ P,MARKINT ;MARK INT. RETS RIGHT THING IN PNT
POP P,B
TRNE B,INTEGR ;CONVERT ONLY TO INTEGER?
JRST GEMGO ;YES, OK.
JRST FIXFL ;GO ON FARTHER
STRCNS: HRRZ TEMP,$PNAME(PNT) ;THIS IS THE SAME CODE AS
JUMPE TEMP,.+3 ; SAIL GENERATES TO DO
MOVE TEMP,$PNAME+1(PNT) ; STRING to INTEGER AT
ILDB TEMP,TEMP ; RUNTIME
TRNN B,INTEGR ;DOES HE WANT AN INTEGER CONST
FLOAT TEMP,TEMP ;NO -- ASSUME FLOATING
JRST CONGO ;GO INSERT A CONSTANT.
FIXFL:
TRNN TBITS,DBLPRC ;INPUT LONG?
JRST FXFLS1 ;NO
EXCH B,-1(P) ;ULTIMATE DESIRES
MOVEI TEMP,FXFLL1 ;RETURN ADDR
EXCH TEMP,(P)
PUSH P,B ;ORIGINAL DIRECTIVE BITS
PUSH P,TEMP ;OLD AC D
MOVSI A,(<SNGL>) ;WHAT TO EMIT, IF WE HAVE TO
MOVEI B,FLOTNG ;WHAT WE WANT, TEMPORARILY
TLNN TBITS,CNST
JRST UUOGO ;CONVERT TO SINGLE REAL, COME BACK TO FXFLL1
SNGL TEMP,$VAL(PNT) ;DO THE OP ON A CONSTANT
JRST CONGO ;RECORD RESULTS
FXFLL1: POP P,B ;ULTIMATE DESIRES ARE BACK
JRST LEPPRE ;PROBLEM HAS BEEN REDUCED ONE NOTCH
FXFLS1:
TRNN B,DBLPRC ;OUTPUT LONG?
JRST FXFLS2 ;NO
TLNE TBITS,CNST ;CONSTANT?
JRST [MOVE TEMP,$VAL(PNT) ;YES, GET VALUE
;;#YB# ! JFR 1-3-77 COMPLETE TYPO
TRNN TBITS,FLOTNG ;ALREADY REAL?
FLOAT TEMP,TEMP ;NO
SETZM DBLVAL ;SECOND WORD IS ZERO
JRST CONGO] ;THE EASY WAY
GENMOV (GET,DBL!INSIST,FLOTNG) ;LOAD IT FLOTNG
PUSHJ P,CLEARA ;THEN FORGET YOU DID IT
MOVE FF,-1(P) ;ORIGINAL DIRECTIVE BITS
IORI B,DBLPRC
ADDI D,1 ;AND ZERO THE NEXT
FXFLL2: EMIT (<SETZ NOADDR>)
SOJA D,TGO1 ;MARK RESULT
FXFLS2:
;;%DN% JFR 7-1-76
MOVE TEMP,ASWITCH ;OPTION BITS
MOVSI A,(<FIX>) ;ASSUME STANDARD
TRNE TEMP,AFIXR
MOVSI A,(<FIXR>)
TRNE TEMP,AKIFIX
MOVSI A,(<KIFIX>)
MOVE USER,A ;COPY THE DECISION
OR USER,[TEMP,TEMP] ;INSERT AC AND ADDR FIELDS
;;%DN% ^
MOVE TEMP,TBITS ;GET OR OF `SHORT' BITS
OR TEMP,B
TRNE B,INTEGR ;RESULT FIXED?
JRST FIX ;YES
;;%DN%
MOVE TEMP,ASWITCH
MOVSI A,(<FLOAT>)
TRNE TEMP,AFLTR
MOVSI A,(<FLTR>)
MOVE USER,A
OR USER,[TEMP,TEMP]
MOVE TEMP,TBITS ;GET OR OF `SHORT' BITS
OR TEMP,B
;;%DN% ^
TLNE TBITS,CNST ;CONSTANT?
JRST FLC
TRNN TEMP,SHORT ;SHORT INTEGER BEGIN FLOATED?
JRST UUOGO ;NO, USE UUO
PUSH P,[FSC USADDR!NORLC] ;INSTR TO FLOAT
HRLI C,233 ;ARGUMENT OF FLOAT INSTR
SHRTCV: MOVE TEMP,-2(P) ;FF BITS COMING INTO TOTAL
TRNE TEMP,SPAC ;WAS SPECIFIC AC REQUIRED
TRO FF,SPAC ;YES, RETAIN IT
PUSHJ P,GET ;GET THE THING
POP P,A ;INSTR
JRST JSTEST ;ALREADY KNOW WHAT AC
FIX: TLNE TBITS,CNST ;CONSTANT?
JRST FLC
NOEXPO<
TRNN TEMP,SHORT ;CONVERT TO SHORT INTEGER?
JRST UUOGO ;NO
PUSH P,[PDPFIX USADDR!NORLC] ;YES, USE PDP-10 INSTR
HRLI C,233000 ;MAGIC ADDR FIELD FOR PDPFIX INSTR
JRST SHRTCV ;DO SHORT CONVERSION
>;NOEXPO
UUOGO: MOVE TEMP,-1(P) ;DIRECTIVE BITS WORD FROM STACK.
TRNE TEMP,SPAC ;IS HE GOING TO WANT A SPECIAL ONE?
JRST JSTEST ;YES
HRR D,$ACNO(PNT)
;;#IA# 6-30-72 DCS (5-6) PROTECT PTRAC AC OVER GETAC
HRLI PNT,-1 ;FLAG, ETC., SEE PART (3-6)
TLNN SBITS,PTRAC
TLZA PNT,-1
HRROS ACKTAB(D)
;;#IA# (5-6)
TLNN SBITS,INAC ;IF NOT IN AN AC, THEN GET ONE.
PUSHJ P,GETAC
;;#IA# 6-30-72 (6-6)
JUMPGE PNT,.+3
HRRZ TEMP,$ACNO(PNT)
HRRZS ACKTAB(TEMP)
;;#IA# (6-6)
GOTACB:
JSTEST:
DPB D,[POINT 4,A,12] ; STORE AC NUMBER IN INSTRUCTION.
PUSHJ P,EMITER
TGO1: HRRZ TEMP,FF ;ORIGINAL FF
TRNE TEMP,NONSTD ;IF NON-STANDARD (SEE SWAP OPER),
JRST [POP P,(P) ; DON'T REMOP OR MARK
JRST GEMGO1] ;BUT RETAIN THE AC USED
PUSHJ P,REMOP ;REMOP THE OPERAND.
TGO: HRRZ TBITS,B ;MAKE TBITS CONFORM TO THE DESIRED TYPE
ANDI TBITS,MASK ;MAKE RESULT LOOK LIKE THE REQUESTS
TLZ SBITS,-1NEGAT ;CLEAR AWAY THE CHAFF
PUSHJ P,MARK1 ;GO DO A MARK.
JRST GEMGO
FLC: MOVE TEMP,$VAL(PNT) ;HERE FOR A CONSTANT.
XCT USER ;DO THE CONVERSION
CONGO: MOVEM TEMP,SCNVAL ;SET UP FOR SYMBOL TABLE INSERTION
HRRZ TBITS,B ;COME HERE TO INSERT A CONSTANT.
ANDI TBITS,MASK
TLO TBITS,CNST
MOVEM TBITS,BITS ;FOR CONINS
PUSHJ P,REMOP ;ALWAYS REMOVE THE OLD GUY
PUSHJ P,CONINS
GEMGO: POP P,D
GEMGO1: POP P,FF ;AT LAST DO THE POP AND
POPJ P, ;ALL DONE -- FULL SPEED AHEAD.
; NOW FOR THE POSTAMBLE (WE WILL AMBLE THROUGH THE COMPILATION).
^^POST: MOVEM SBITS,$SBITS(PNT) ;PUT DOWN SEMANTICS WORDS.
MOVEM TBITS,$TBITS(PNT)
TRNN FF,EXCHOUT!BITS2!REM!UNPROTECT ;THESE ARE THINGS TO DO.
POPJ P, ;ALL DONE.
TRNE FF,REM ;REMOP THE THING?
JRST [PUSHJ P,REMOP ;YES
MOVE SBITS,$SBITS(PNT)
JRST .+1]
TRNE FF,BITS2 ;UPDATE SBITS2?
MOVE SBITS2,$SBITS2(PNT2) ;DONE.
TRNE FF,UNPROTECT
JRST [HRRZS ACKTAB(D)
TDNN TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
TRNN TBITS,DBLPRC
JRST .+1
MOVEI TEMP,(D)
CAIN TEMP,RF-1
ERR <DRYROT POST>,1
CAIE TEMP,RF-1
HRRZS ACKTAB+1(D)
JRST .+1]
TRNN FF,EXCHOUT ;EXCHANGE ON WAY OUT?
POPJ P, ;NO --DONE.
EXCHOP
POPJ P,
COMMENT PUT
^^PUT: TRNE FF,PREMASK ;ANY PREAMBLE TO BE DONE
PUSHJ P,PRE ;YES -- DO IT.
PUSH P,FF ;HERE TO STORE AN ACCUMULATOR INTO
; HAVE PUT ALWAYS DO AN ACCESS
; TLNE SBITS,INDXED ;A DESCRIPTOR
PUSHJ P,ACCOP ;GET ACCESS TO THE TARGET.
TRNE TBITS,STRING ;IF NOT A STRING
TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;OR NOT REALLY A STRING,THEN
JRST APUT ;USE A MOVEM OR THE LIKE.
MOVE A,[POP BPWORD!LNWORD!SBOP!BPFIRST]
PUSHJ P,STROP ;USE THE STRING OPERATION TO PUT OUT POPS.
CAIE D,RSP ;IF IT WAS NOT THE STACK, THEN
PUSHJ P,CLEARA ;CLEAR OUT THIS ACCUMULATOR ENTRY.
;IT WAS CHANGED WHEN THE POPS WERE DONE ANYWAY.
JRST PUTFIN ;ALL DONE. MY THAT WAS SIMPLE.
APUT: PUSHJ P,CLEARA ;CLEAR OUT THE DESTINATION ACCUMULATOR.
TLNE SBITS,INAC ;IF THE DESTINATION OF THE STORE IS ALREADY
PUSHJ P,CLEAR ;IN AN AC, THEN CLEAR IT OUT.
REC <
NORGC <
TRNE TBITS,PNTVAR ;A RECORD ?
TRNE TBITS,777777-(PNTVAR!GLOBL)
JRST APUT2 ;NOPE, JUST DO THE PUT
PUSH P,C ;IT MAY BE USED, NOT SURE
MOVNI C,1 ;DEREFERENCE THE THING IN PNT
PUSHJ P,RFCADJ ;LIKE SO
POP P,C
APUT2:
>;NORGC
>;REC
HRLZI A,(<MOVEM>) ;THE ORDINARY STORE INSTRUCTION.
TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
JRST .+3 ;SUFFICES IN ANY CASE FOR AN ARRAY, ITEM, ITEMVAR
TRNE TBITS,DBLPRC
HRLZI A,(<DMOVEM>)
TLNN SBITS,NEGAT ; BUT IF NEGATED, USE THE OTHER
JRST .+4 ;NOT NEGATED
TRNN TBITS,DBLPRC ;DOUBLE?
TLCA A,(<MOVNM><MOVEM>) ;NO. MAKE INTO MOVNM
TLC A,(<DMOVNM><DMOVEM>) ;YES. MAKE INTO DMOVNM
;; #OX# TREAT ? ITEMVARS SPECIALLY
TLNE TBITS,MPBIND
JRST [HRR C,D ;SAVE AC NUMBER
GENMOVE (GET,ADDR!INDX)
MOVSS D
HRR D,C ;XWD INDX,,AC
MOVE A,[MOVEM USX+NORLC+NOADDR]
JRST .+1
] ;GO AWAY
;; #OX#
PUSHJ P,EMITER ;AND PUT OUT THE INSTRUCTION.
TLNE SBITS,INDXED ;WE DO NOT WANT TO MARK *********
JRST PUTFN1 ;GO AWAY.
HRRM D,$ACNO(PNT) ;AND THE AC IT IS IN
HRRM PNT,ACKTAB(D) ;IN TWO PLACES.
;THIS UNPROTECTS THIS ACCUMULATOR.
TLNN SBITS,PTRAC
TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
JRST .+3
TRNE TBITS,DBLPRC
JRST [SKIPE ACKTAB+1(D)
ERR <DRYROT PUT DOUBLE>,1
MOVEI TEMP,(D)
CAIE TEMP,RF-1 ;DO NOT CLOBBER RF!
HRRM PNT,ACKTAB+1(D)
JRST .+1]
TLOA SBITS,INAC ;AND NOW MARK THE DESCRIPTOR BITS
PUTFN1: TLZ SBITS,NEGAT ;SUBSCRIPTED, NEGAT GETS IN WAY (BELIEVE!)
PUTFIN: POP P,FF ;ALL DONE
JRST POST ;AND FINISH OUT.
COMMENT ACCESS,GETSDR,GETDR,DISBLK,ZOTDIS--last four only for dis
Call ACCOP when you need to reference a thing and don't know whether you
can get at it in a single instruction (i.e. an indexed thing).
GENMOV(ACCESS) will cause ACCOP to be called for you.
People like GET and STACKOP do it automatically.
^^ACCESS: TRNE FF,PREMASK
PUSHJ P,PRE
PUSHJ P,ACCOP
JRST POST
ACCOP: TDNN SBITS,[XWD INDXED,DLFLDM]; ONLY CARE IF INDEXED OR NEED A DISPLY
POPJ P,
TLNE SBITS,INAC!PTRAC ;IF IN AN AC WE CAN ACCESS IT
POPJ P,
TRNN SBITS,DLFLDM ;IF DISPLAY LEV=0 ONLY CARE ABOUT INDEXED
JRST INXSTF ;NO WORRY ABOUT THE DIAPLAY
LDB TEMP,[LEVPOINT<SBITS>] ;PICK UP DISPLY LEV
TRNE TBITS,STRING ;IS ITT A STRING
JRST [
;; #JR# BY JRL 10-17-72 ITEMVARS,ARRAYS DON'T USE STRING STACK
TDNN TBITS,[REFRNC!SBSCRP,,ITEM!ITMVAR];THESE THINGS DON'T USE
TLNE SBITS,INDXED ;INDEXED? ;STRING STACK
JRST .+1
;; #JR#
JRST GETSDR ;GET STRING DR
]
PUSHJ P,GETDR ;GET A DISPLAY REG LOADED
;;%DU% JFR 1-4-77
TRNE FF,ACESS2 ;DIRECT TO 2ND WD
TRNN TBITS,DBLPRC ; OF LONG?
JRST ACCOP1 ;NO
TLNE TBITS,REFRNC
JRST ACMOP ;APPARENTLY ONLY REF. FORMALS NEED THIS
ACCOP1:
;;%DU% ^
TRNN SBITS,INDXED ;INDEXED TOO?
POPJ P, ;NO
INXSTF:
;;#JR#
TRNN TBITS,ITEM!ITMVAR
TRNN TBITS,STRING ;ALWAYS NEED STRING GUYS
JRST .+2
;;#JR#
JRST ACMOP
HRRZ TEMP,$VAL(PNT) ; ONLY NEED IT IF NON-ZERO
JUMPE TEMP,CPOPJ ; DISPLACEMENT
ACMOP: TLNE SBITS,PTRAC ;IS IT ALREADY ACCEPTABLE (IN AC)?
POPJ P, ; YES, WHY HAVE WE WORRIED?
PUSH P,D ;HAVE TO SAVE CURRENT AC
PUSH P,A
PUSH P,FF
MOVE TEMP,FF
HRRI FF,INDX ;SO THAT NOTHING NONSTD WILL HAPPEN.
MOVE A,[XWD 40!2!1,ADDR] ;SET NECESSARY BITS
;(SPECIAL BIT, MOVE, GET AC, USE INDXBLE AC, GET ADDR)
;;%DU%
TRNE TEMP,ACESS2
TRNN TBITS,DBLPRC
CAIA
TLO A,400 ;DO NOT CHANGE SBITS(PNT)
;;%DU% ^
PUSHJ P,GETWD
POP P,FF
;;%DU% JFR 1-4-77
TRNE FF,ACESS2
TRNN TBITS,DBLPRC
JRST ACMOP1 ;NOT SPECIAL 2ND WD ACCESS
PUSH P,TBITS
SETZB TBITS,SBITS
PUSHJ P,GETTEM ;WE HAVE GOTTEN THE ADDR INTO A TEMP
MOVEM D,$ACNO(LPSA) ;REMEMBER INTO WHICH AC
HRRM LPSA,ACKTAB(D)
POP P,$TBITS(LPSA)
HRRZS TBITS,$TBITS(LPSA) ;SANITIZE THE TYPE
MOVSI SBITS,ARTEMP!PTRAC!INDXED
MOVEM SBITS,$SBITS(LPSA)
SETZM $VAL(LPSA) ;DISPLACEMENT IS ZERO
MOVEI PNT,(LPSA) ;OUR NEW OPERAND
ACMOP1:
;;%DU% ^
POP P,A
POP P,D
POPJ P,
COMMENT
DSCR GETSDR,GETDR
DES ROUTINES TO LOAD UP STRING (ARITHMETIC) DISPLAYS
LOADS UP LPSA WITH THE AC NO TO USE & FIXES UP ACTAB,DISTAB,&DISLST
PARM TEMP=LEVEL DESIRED
SID MANGLE TEMP,LPSA
STORES LEVEL IN LSDRLV, STORES DR # IN LSDRNM (LH FOR SDR & RH FOR DR)
;;#MN# 7-13-73 FIX ACCESS PROBLEM
ZERODATA(EMITTER DATA)
LSDRLV: 0 ;SEE ABOVE
LSDRNM: 0
ENDDATA
^^GETSDR:
HRLM TEMP,LSDRLV ;REMEMBER LEVEL OF STRING REQUEST
HLRZ LPSA,DISTAB(TEMP) ;DO WE HAVE IT ALREADY
HRLM LPSA,LSDRNM ;IF SO REMEMBER
;;#MN#
JUMPN LPSA,CPOPJ ;YES
PUSHJ P,GETDR ;GET THE P-DISPLY
PUSH P,FF ;WHAT A PITY WE MIGHT HAVE JUST POPPED
PUSH P,A ;BUT THIS IS QUICKER IN THE LONG
PUSH P,B ;RUN THAN MESSING WITH FLAGS
PUSH P,C ;
PUSH P,D
TRZ FF,DBL ;ONLY ONE AC
HRL D,LPSA ;USE P-DR AS INDEX
MOVE B,TEMP ;WE WILL NEED THIS
HRLI C,2 ;DISPL OF 2
PUSHJ P,GETAN0 ;GET AN AC FOR DISPLY
EMIT (<MOVE ,USX!USADDR!NORLC>) ;LOAD THE DR
HRLM D,DISTAB(B) ;ENTER INTO DISPLAY TABLE
PUSHJ P,DISBLK ;SET UP MOST OF BLOCK
MOVEI TEMP,STRING ;
HRRZM TEMP,$TBITS(LPSA) ;MAKE TYPE RIGHT
MOVSS $VAL(LPSA) ;FIX UP AND MASK
;;#MN# !
HRLM LPSA,LSDRNM
JRST RETSEQ ;GO POP STUFF & RETURN
^^GETDR:
;;#MN# !
HRRM TEMP,LSDRLV
HRRZ LPSA,DISTAB(TEMP) ;PICK UP THE PUTATIVE REGISTER
;;#MN# !
HRRM LPSA,LSDRNM
JUMPN LPSA,CPOPJ ;IF THERE,RETURN
PUSH P,FF
PUSH P,A
PUSH P,B
PUSH P,C
PUSH P,D
PUSH P,TEMP ;GETDR MUST SAVE IT
TRZ FF,DBL ;ONLY ONE AC
HRRZI B,1(TEMP) ;NEXT LEVEL DEEPER
GDR1: HRLZ D,DISTAB(B) ;PICK IT UP
CAIN D,0 ;IS IT LOADED
AOJA B,GDR1 ;NO
HRLI C,1 ;SET TO SELECT STATIC LINK
MOVE A,[<MOVE 0,USX!NORLC!USADDR>]
GDR2: PUSHJ P,GETAN0 ;THIS BETTER LEAVE LH(D) ALONE -- IT DOES
PUSHJ P,EMITER ;UP ONE STATIC LINK
SOS B ;BACK A LEVEL
HRRM D,DISTAB(B) ;SAY WE HAVE IT
PUSHJ P,DISBLK ;TO DO STUFF FOR DISPLAY BLOCK&ACKTAB
CAMN B,(P) ;IS THIS THE ONE WE WANT
JRST GDR4 ;YES
GDR3: HRL D,D ;USE AS INDEX PERHAPS
HRR D,DISTAB-1(B) ;NEXT AC BACK
TRNE D,-1 ;IS IT THERE
SOJA B,GDR3 ;YES
JRST GDR2 ;NO--FETCH IT
GDR4: HRRZ LPSA,D ;AC NO OD DISPLY
;;#MN# !
HRRM LPSA,LSDRNM ;REMEMBER NUMBER
POP P,TEMP
;;#UW# ! JFR 8-17-75 CALL TO EMITER AT GDR2+1 WIPED OUT LSDRLV
HRRM TEMP,LSDRLV
RETSEQ: POP P,D
POP P,C
POP P,B
POP P,A
POP P,FF
POPJ P, ;RETURN
COMMENT
DSCR DISBLK
DES THIS PROCEDURE SETS UP DISPLAY SEMBLK STUFF & UPDATES ACKTAB
IT SETS LPSA TO POINT ATE THE NEW SEMBLK
THE BLOCK IS SET UP FOR A LPSA TYPE SEMBLK
PARM B = DISPLAY LEBEL
D= ACNO OF DISPLAY REG
^^DISBLK:
GETBLK ;GET A BLOCK
HRRM D,$ACNO(LPSA) ;SAVE AC NO
HRRM B,$ADR(LPSA) ;LEVEL GOES HERE
SETOM TEMP
HRLZM TEMP,$VAL(LPSA) ;SETS UP ANDING MASK
MOVE TEMP,[XWD PTRAC!INAC!DISTMP,INTEGR]
HRRZM TEMP,$TBITS(LPSA) ;$TBITS WORD
HLLZM TEMP,$SBITS(LPSA) ;$SBITS WORD
PUSHJ P,RNGDIS ;PUT IT ON DISLST LIST
HRRZM LPSA,ACKTAB(D) ;MARK AC FULL OF IT
POPJ P, ;RETURN
COMMENT
DSCR ZOTDIS
DES this procedure will wipe out your current display
PARM None
SID LPSA,TEMP used
^^ZOTDIS:
PUSH P,D ;SAVE
PUSH P,A
MOVE A,CDLEV ;CURRENT DISPLAY LEVEL
ZDIS.1: SOJL A,ZDIS.2
HRRZ D,DISTAB+1(A)
CAIE D,RF ;DONT ZONK RF
CAIN D, ;DONT DO ANYTHING IF NOT THERE
SKIPA
PUSHJ P,STORZ
HLRZ D,DISTAB+1(A)
CAILE D,
PUSHJ P,STORZ
SETZM DISTAB+1(A)
JRST ZDIS.1
ZDIS.2: POP P,A
POP P,D
POPJ P,
COMMENT GET
GENMOV(GET) generally invokes this routine.
It has many purposes, depending on the entity to be "getted".
Briefly, however, it loads an AC with the thing one
wants in order to store or compute using the entity in
question. For strings, it loads a string address
with the left half negative (for popping). For
INDXED guys (with ADDR turned on), it loads
the result of the index calc to an ac if it was not
there. For regular variables, it simply picks them
up if they are not in an AC. The bits
ADDR, INDX, DBL, POSIT, NEGAT, and MARK
may be used to modify the action of GETOPE.
^^GET: TRNE FF,PREMASK ;ANYTHING TO DO??
PUSHJ P,PRE
TRC FF,INSIST!NONSTD ;IF NO MARKING TO BE DONE, AND
TRCE FF,INSIST!NONSTD ; A TYPE CONVERSION WAS DONE,
JRST GETOPE
;; #OZ# (1 OF 1) PRE DOESN'T DO A GET OF ITEMS OR ITEMVARS
TRNE B,ITMVAR!ITEM ; PRE DID NOT DO A GET
; IF ITEMVARS OR ITEMS
JRST GETOPE
;; #OZ#
HRRZ TEMP,B ; (COMPARE INSISTED TYPE WITH
CAIE TEMP,(TBITS) ; ACTUAL TYPE), THEN DON'T GET
JRST POST ; AGAIN
^GETOPE:
PUSHJ P,ACCOP ; ESTABLISH ACCESS TO THE EFFECTIVE ADDRESS.
COMMENT IF STTEMP, NO MORE WORK NECESSARY
(ASSUME STRING IS ON)
TLNN SBITS,STTEMP
JRST GETOPC
TRNN FF,ADDR ;MUST GO THRU WITH IT IF ADDR
JRST TMPRET
COMMENT USE LEFT HALF OF A TO HOLD SOME EXTRA BITS:
1 -- NEED AN AC (GETAC)
2 -- DO A MOVE OF SOME SORT
4 -- DO A MOVN
10 - MAKE IT A HRRO
20 - MAKE IT A HRROI, FOR STRING INDXED GUYS (SEE BELOW)
40 - SPECIAL ACCOP BIT, SEE GETRET BELOW
100 - SEEMS TO MEAN MOVEI -- WASN'T DOCUMENTED, DAMMIT
200 - SPECIAL KLUGERY FOR RECORDS
400 - KLUGE TO PREVENT GET ADDR OF REGULAR THING
FROM MARKING INAC.
1000 - USE DOUBLE WORD INSTRUCTIONS (DMOVE, ...) INSTEAD OF SINGLE (MOVE,...)
NEED EXTRA CHECKS IF ENTITY IS ALREADY IN AN AC
GETOPC: HRLZI A,3 ;ASSUME NEED A MOVE
TRNE FF,SPAC ;UNLESS AC # PROVIDED,
TLZ A,1 ; ASSUME AC NEEDED
TLNN SBITS,INDXED ;IF INDEXED, THEN TURN OFF NONSTD.
TRZ FF,NONSTD ;SO AS NOT TO FOUL UP.
REC <
TRNE TBITS,PNTVAR ;MAKE SURE ONLY DO KLUGE IF A RECORD
TRNE TBITS,777777-(PNTVAR!GLOBL) ;ONLY THAT BIT IS ALLOWED TO BE ON
JRST NOSPAC ; NOT A RECORD
;;#SA# ! GET ADDR IS JUST NORMAL
TRNE FF,ADDR ;WELL??
JRST NOSPAC
HLRZ TEMP,$ACNO(PNT) ;IN CASE WE WANT A MARK (USUALLY WILL)
TRNE FF,MRK ;TEST IT OUT
HRRZM TEMP,RCLASS ;NOW THE MARK WON'T DRYROT
TLNE TBITS,CNST ;CONSTANTS ARE GETTABLE DIRECTLY
JRST [ CAME PNT,NLRCBK ;THIS SHOULD BE THE ONLY ONE POSSIBLE
ERR <RECORD CLASS TEMP OTHER THAN NULL RECORD?>,1
JRST NOSPAC
]
TLNN SBITS,ARTEMP ;IF NOT A TEMP
JRST RECKL1 ;THEN DO THE FIRST PART OF RECORD KLUGE
TLNN SBITS,INDXED ;IF NOT INDEXED TEMP BUT A TEMP
JRST NOSPAC ;DON'T DO ANYTHING ABOUT THIS
;WE WILL PERFORM THE INCREMENT OF
;THE REF CNT FOR ANY VARIABLE OR
;INDXED TEMP, WHETHER A SUBFIELD OR NOT
RECKL1:
NORGC <
TLO A,200 ;BIT THAT SAYS TO DO RECORD ACCESS
>;NORGC
TRNN FF,SPAC ;KLUGE TO GET AC # GOOD
TRO FF,INDX ;IF WE GET ONE, IT BETTER BE INDEXABLE
IFN 0,<
TLNE SBITS,INAC ;IF INAC, WE WILL FORGET IT FOR THIS PURPOSE
PUSHJ P,[ TLNE SBITS,INDXED ;BIG SURPRIZE IF THIS IS ON
ERR <DRYROT: INDXED INAC?>,1
;;#SV# RHT MUST PRESERVE D
PUSH P,D
HRR D,$ACNO(PNT) ;GET OUT OF THE AC & THEN WILL WIN
PUSHJ P,CLEARA ;FORGET INACITUDE
POP P,D
JRST GETAD ;REFURBISH THE BITS & RETURN FROM LITERAL
]
>;FALSE
;; FALL INTO NOSPAC
>;REC
NOSPAC: TLNN SBITS,INAC!PTRAC;IF IN AC, HAVE TO BE SURE IT'S RIGHT
JRST STCHK ; IF NOT, MUST CHECK
; FOR STRINGS (HAVE TO LOAD)
;DBLPRC PTRAC MUST TURN ON DBL UNLESS ADDR
TRNN FF,ADDR
TLNN SBITS,PTRAC
JRST NOSPA1
TDNN TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
TRNN TBITS,DBLPRC
JRST NOSPA1
IORI FF,DBL
NOSPA1:
Comment INAC -- if DBL or INDX or SPAC,
find out if thing can stay in this AC -- otherwise
must get another.
; FIRST CHECK SPAC GUYS
TLZ A,1!2 ;ASSUME NOTHING YET
TRNN FF,SPAC ;PROVIDED WITH SPECIFIC AC?
JRST DBCHK ; NO, CHECK DBL WANTED
HRRZ TEMP,$ACNO(PNT) ;GET CURRENT AC #
CAIN TEMP,(D) ;DID WE LUCK OUT (SAME ONE)?
JRST SBSCHK ;YES, GO CHECK SPECIAL INDXED THING
;DCS 8/16/70 IF SPAC AC BEING REPLACED,
; STORE AND CLEAR WHAT'S IN IT
SKIPLE ACKTAB(D) ;PROTECTED OR NOTHING THERE?
PUSHJ P,STORZ ; NO, GET RID OF IT
;DCS 8/16/70
TLO A,2 ;WILL HAVE TO DO A MOVE
JRST WPCHK1 ;AND MAKE SEMANTICS CHANGES
; IF DBL IS ON, SEE IF NEXT AC IS FREE, SET UP TO MOVE IF NOT
DBCHK:
HRR D,$ACNO(PNT) ;GET CURRENT AC NUMBER
TRNN FF,DBL ;WELL
JRST IDXCHK ;NO DBL REQUESTED
SKIPGE ACKTAB+1(D) ;NEXT ONE NOT USABLE?
JRST WIPCHK ; CANNOT BE USED, MAKE SEMANTIC CHANGES
HRRI D,1(D) ;STORE THE NEXT
PUSHJ P,STORZ
HRRI D,-1(D) ;RESTORE AC #
IDXCHK: TRNE FF,INDX ;NEED INDX?
TRNE D,-2 ; AND NOT IN ONE ALREADY?
JRST SBSCHK ;OK, 'TWOULD SEEM
Comment If AC # is being changed (INAC and NEEDAC or SPAC and MOVE)
clear right half of ACKTAB(AC), but first be sure nothing will be
wiped out
WIPCHK: TLO A,1!2 ;HAVE TO MOVE IT
WPCHK1: HRRZ TEMP,$ACNO(PNT) ;IT IS HERE CURRENTLY
SKIPGE ACKTAB(TEMP) ;WAS THIS AC PROTECTED?
ERR <DRYROT --AC CLOBBER>,1
SETZM ACKTAB(TEMP) ;"STORR" (STORL DONE BEFORE)
TDNN TBITS,[SBSCRP,,ITEM!ITMVAR!PROCED]
TRNN TBITS,DBLPRC
JRST WPCHK2 ;NOT VALUE LONG
TLNE SBITS,PTRAC
JRST WPCHK2 ;NEITHER IS THIS
CAIN TEMP,RF-1
ERR <DRYROT WIPCHK>,1
CAIE TEMP,RF-1
SETZM ACKTAB+1(TEMP) ;CLEAR 2ND AC OF LONG
WPCHK2:
Comment for STRING INDXED quantities (or non-STRING with ADDR)
(guaranteed INAC by now) requiring a displacement,
a "HRROI" FXTWO (or MOVEI)must be done --
"HRRO" ("MOVE") with ADDR would yield a no-op
SBSCHK: TLNN SBITS,INDXED ;TEST THE CONDITONS
JRST POSN ; NOT INDEXED
HRRZ TEMP,$VAL(PNT) ;0 DISPLACEMENT?
JUMPE TEMP,POSN ; NO DISPLACEMENT, NO PROBLEM
;; #OR# ! A STRING ITEMVAR IS NOT A STRING
;; #UE# ! NOR IS A STRING ARRAY
TDNN TBITS,[XWD SBSCRP,ITMVAR!ITEM]; A STRING ITEM IS NOT A STRING
TRNN TBITS,STRING ;INDXED STRING?
JRST CHKNUM ; NO, CHECK GET!ADDR FOR NUMERIC ARRAY
TRZ FF,ADDR ;JUST IN CASE
TLO A,2!20 ;MOVE, HRROI, NO ADDR
JRST POSN
CHKNUM: TRZE FF,ADDR ;WANT THE ADDRESS ALL TOGETHER?
TLO A,100!2 ; YES, MOVE, MOVEI
JRST POSN
Comment for strings, we must do a HRRO with ADDR
turned ON (except for SBSCRP strings)
STCHK: TRNE FF,SPAC ;STORE AC IF SPAC
PUSHJ P,STORZ
TRNE TBITS,STRING ;STRING, NOT SBSCRP?
;;#VJ# ! JFR 10-17-75 A STRING PROCEDURE IS NOT A STRING, EITHER
TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR!PROCED] ;NOT REALLY A STRING?
JRST POSN
TDO A,[XWD 2!10,ADDR] ;DO A "HRRO" ADDR
; IF (POSIT(A) and NEGAT(SBITS)) or (NEGAT(A) and NEGAT(SBITS)) MUST
; DO SOMETHING ABOUT IT
POSN: TRNE FF,POSIT ;FIRST CONDITION
TLNN SBITS,NEGAT
JRST CHNGAT ; UNSATISFIED
TLZ SBITS,NEGAT ;NO LONGER NEGAT
TLO A,2!4 ;DO "MOVN"
JRST CHKDX ;GO CHECK INDEXED
CHNGAT: TRNE FF,NEGAT ;SECOND CONDITION
TLNE SBITS,NEGAT
JRST CHKDX ; UNSATISFIED
TLO SBITS,NEGAT ;NOW NEGAT
TLO A,2!4 ;DO A "MOVN"
CHKDX: TLNN SBITS,INDXED ;IF INDXED, NOT STRING, NOT ADDR, BE
JRST ADRCK
;; #RE# (1 OF 1) A STRING ITEMVAR ARRAY NOT A STRING ARRAY
;; #UE# ! (2 OF 3) STRING ARRAY INDXED TEMPS EXIST TOO
TDNE TBITS,[XWD SBSCRP,ITMVAR!ITEM]
JRST CHKDX2
TRNE TBITS,STRING
JRST ADRCK ;DOES NOT NEED A HRRO, HRROI
CHKDX2:
;; # RE#
;;#TE# DAMNED CODE WAS PUTTING RESULT OF GET ADDR INAC
TRNN FF,ADDR
TLOA A,2 ; SURE SOME SORT OF MOVE GETS DONE
TRO A,ADDR ;IN CASE OF INDXED THING, OK TO SAY "INAC"
JRST ADRCKD ;(IF WAS STRING, MARKING INAC DOESN'T HURT)
ADRCK: TRNE FF,ADDR ;NOW COPY THIS INTO A
;;#TE# ! USED TO BE A TRO A,ADDR
TDO A,[400,,ADDR] ;LIKE ALL CPA'S.
TRNE A,ADDR
JRST GETWD ;WANT THE ADDRESS
ADRCKD:
TDNN TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR] ;THESE ARE BOGUS
TRNN TBITS,DBLPRC
JRST GETWD ;NOT DOUBLE
TLO A,1000 ;USE DBL MOVES
IORI FF,DBL ;AND DBL ACS
GETWD: TRNN FF,NONSTD ;THE NON-STANDARD TYPE WILL
;**ALWAYS** GET AN AC.
TLNE A,1 ;NEED AC?
PUSHJ P,GETAC ; YES, GOT IT
TLNN A,2 ;NEED TO MOVE?
JRST [TLNN SBITS,INAC!PTRAC ;STRIVE TO PUT BITS BACK RIGHT
JRST TMPRET
TLNE SBITS,INDXED
JRST IDXRET
JRST GETRET] ;BEST AS POSSIBLE THE SAME AS ON ENTRY
MOVE TEMP,A ;SAVE BITS SO YOU CAN TEST THEM
PUSH P,A ;SAVE LH BITS
HRLI A,(<MOVE>) ;ASSUME "MOVE"
TLNE TEMP,1000 ;DOUBLE?
HRLI A,(<DMOVE>)
TLNE TEMP,4 ;MOVN?
JRST [HRLI A,(<MOVN>) ; YES
TLNE TEMP,1000
HRLI A,(<DMOVN>) ;DOUBLE MOVN
JRST .+1]
TLNN TEMP,20!10 ;HRRO OR HRROI?
JRST NOHRRO ;NO
TRO A,FXTWO
HRLI A,(<HRRO>)
TLNE TEMP,20 ;ETC.
HRLI A,(<HRROI>)
NOHRRO:
PUSH P,PNT
TRNE TBITS,ITMVAR
TLNN TBITS,MPBIND ;IF NOT ?ITEMVAR
JRST NOTMPP ;CONTINUE
TRZ A,ADDR
;; JRL FOLLOWING WAS MISTAKENLY A HRRI
HRLI A,(<MOVEI @>)
TRNE TEMP,ADDR ;ADDR REQUESTED
;; JRL FOLLOWING WAS MISTAKENLY A HRRI
HRLI A,(<MOVE>)
JRST EMTMOV ;EMIT THE MOVE
NOTMPP: TLNE TEMP,100 ;FOR GET ADDR
HRLI A,(<MOVEI>)
TRO A,IMMOVE ;IF POSSIBLE
TRNE TBITS,ITEM ;OH MY GOSH AROODIES.
JRST [TLNN TBITS,FORMAL!SBSCRP
MOVE PNT,$VAL2(PNT) ; IT WILL BE AN INTEGER....
JRST EMTMOV]
REC <
NORGC <
TLNN TEMP,100 ;SPECIFIED IMMEDIATENESS
TLNN TEMP,200 ;NO, THEN RECORD KLUGE IS A LIVE OPTION
JRST EMTMOV ;NOT A RECORD KLUGERY INSTANCE
RECKL2: HRLI A,(<SKIPE>) ;NEED TO BUMP REF CNT IF NOT NULL
;;BUG TRAP
TRZE A,USCOND
ERR <DRYROT: USCOND ON AT RECKL2>,1
PUSHJ P,EMITER
HRLOI A,(<AOS>) ;
TLO A,(D) ;PUT AC NUMBER IN PLACE
TLZ FF,RELOC ; NOT A RELOCATABLE -1 !
PUSHJ P,CODOUT ; AOS -1(AC)
SKIPA ;SKIP OVER EMITER CALL AT EMTMOV
>;NORGC
>;REC
EMTMOV: PUSHJ P,EMITER
POP P,PNT ;IN CASE OF ITEM.
POP P,A
TLNE TBITS,MPBIND
JRST [TLO SBITS,INAC
TRNN A,ADDR ;ADDR?
JRST ALLRET ;NO.
;; #PA#!(1OF 2) SAVE C ON CALL TO GET
PUSH P,C
HRLZI C,20 ;INDIRECT BIT
EMIT <TLZN ,USADDR!NORLC>
;; #PA#!(2 OF 2) RESTORE C
POP P,C
EMIT <MOVEI ,0>
TLZ SBITS,INAC
JRST TMPRET] ;DON'T REMEMBER ADDR IS IN AC
;;#TE# DONT WANT TO ALWAYS REMEMBER THIS AC IN $ACNO
GETRET: TLNN A,400 ;WAS IT REGULAR VBL, GET (ADDR)
TRNE FF,NONSTD ;SPECIAL CASE OF PRESERVING INDXD TEMPS
JRST [MOVE SBITS,$SBITS(PNT) ;RESTORE OLD MARKING.
JRST TMPRT1] ;AND FINISH OUT.
TLZ SBITS,PTRAC!INDXED!INAC ;START FROM SCRATCH
TLNN A,20!40!100 ;INAC MARKING?
JRST STDRET ; YES, DO IT
IDXRET: TLO SBITS,PTRAC!INDXED;KEEP INDXED BITS
TLNN A,20!100 ;HRROI (MOVEI) THING?
JRST ALLRET ; NO
TLZ TBITS,OWN
HLLZS $VAL(PNT) ; NO DISPL ANYMORE
JRST ALLRET
STDRET: TDNN TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;NOT REALLY A STRING?
TRNN TBITS,STRING ;KEEP BITS OFF IF STRING
TLO SBITS,INAC
ALLRET: HRRM PNT,ACKTAB(D) ;UPDATE SEMANTICS AND
HRRM D,$ACNO(PNT) ; ACKTAB
TLNN SBITS,PTRAC
TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR] ;THESE ARE BOGUS
JRST .+3
TRNE TBITS,DBLPRC
JRST [MOVEI TEMP,(D)
CAIN TEMP,RF-1
ERR <DRYROT ALLRET>,1
CAIE TEMP,RF-1
HRRM PNT,ACKTAB+1(D) ;SECOND AC OF DOUBLE
JRST .+1]
TMPRET: MOVEM SBITS,$SBITS(PNT) ;IF ACCOP, THIS WILL BE NECESSARY
TMPRT1: TRNN FF,MRK ;DOES HE WANT A MARK?
JRST POST ;ALL DONE.
PUSHJ P,REMOP ;AFTER ALL THAT?
JRST MARK1 ;AH, WELL
COMMENT STACK -- Issue Instrs. to Stack Anything on Approp. Stack
^^STACK: TRNE FF,PREMASK ;ANY TO DO?
PUSHJ P,PRE
PUSHJ P,STACK1
TRNN FF,MRK ;HAS HE ASKED FOR A MARK?
JRST POST ;FINISH OUT.
JRST MARK1 ;AND DO A MARK.
STACK1: PUSH P,FF ;SAVE
TRNN SBITS,DLFLDM ;DOES HE LIVE IN THE STACK?
TLNE SBITS,INDXED
PUSHJ P,ACCOP ;GET ACCESS.
TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;ALWAYS STACK ARRAYS ON P-STACK
JRST ASTACK ; NO MATTER WHAT
TRNN FF,ADDR ;MUST BE A CALL BY REF.
TRNN TBITS,STRING ;STRING STACK?
JRST ASTACK ;NO -- ARITHMETIC
TLNE SBITS,STTEMP ;IF STTEMP and INUSE,
; ALREADY STACKED, DON'T DO AGAIN
JRST MARTK ;JUST MARK AND QUIT
MOVEI D,RSP ;TO AVOID CLOBBERING CORE.
MOVE A,[PUSH RSP,STAK!BPWORD!LNWORD!ADOP!REM]
TRNE FF,REM ; IF REM BIT IS ON IN FF THEN DON'T REMOP IN
TRZ A,REM ; STROP1 SINCE POST WILL DO IT
PUSHJ P,STROP1 ;THIS IS REALLY EASY. DO TWO PUSHES.
;; FOLLOWING WAS ERRONEOUSLY TO MARTK THUS REMOPING BLOCK TWICE
;; #ML ACTUALLY NEED TO LOAD SBITS AGAIN SHOULD BE MARTJ
JRST MARTJ ;AND NOW MARK THINGS.
ASTACK: TLZN SBITS,NEGAT ;ARE THINGS CURRENTLY NEGATIVE?
JRST OKPO ;NO
TLNN SBITS,INAC!PTRAC
ERR <DRYROT -- STACK NEGAT IN CORE?>,1
HRL C,$ACNO(PNT)
TRNE TBITS,DBLPRC
JRST [HLR D,C ;SAME AC AS ADDR
EMIT (DMOVN USADDR!NORLC) ;DMOVN AC,AC
JRST ASTA.1]
EMIT (MOVNS USADDR!NORLC!NOUSAC)
ASTA.1: MOVEM SBITS,$SBITS(PNT);FOR THE EMITER.
OKPO:
REC <
NORGC <
TRNE TBITS,PNTVAR ;IS IT A PNTVAR (IE RECORD)
TRNE TBITS,777777-(PNTVAR!GLOBL) ;
JRST OKPO.1 ;NO
TRNE FF,ADDR ;WANT ADDRESS?
JRST OKPO.1 ;WON'T WORK ANYHOW
PUSH P,FF ;
GENMOV (GET,MRK) ;GET IT & MARK IT
POP P,FF
OKPO.1: ;
>;NORGC
>;REC
TLNE TBITS,MPBIND ;A ?ITEMVAR
JRST [TRNE FF,ADDR ;ADDRESS REQUIRED?
ERR <DRYROT -STACK ADDR ? ITEMVAR>
TLNE SBITS,PTRAC!INAC
JRST .+1
PUSH P,D
PUSHJ P,GETAC
EMIT <MOVEI @,>
PUSHJ P,MARKINT
POP P,D
JRST .+1]
HRLZI A,(<PUSH RP,>)
TRNE FF,ADDR ;COPY THIS BIT.
TRO A,ADDR
TRO A,NOUSAC ;WE HAVE SPECIFIED IT.
PUSHJ P,EMITER ;PUT OUT THE PUSH.
AOS ADEPTH ;SINCE WE USED THE PSTACK
TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR] ;THESE ARE NOT DOUBLE
JRST MARTK
TRNE TBITS,DBLPRC
TRNE FF,ADDR
JRST MARTK ;ADDR OR NOT DOUBLE
EMIT (<PUSH RP,NOUSAC!FXTWO>) ;SECOND WORD
AOS ADEPTH
MARTK: TRNN FF,REM ;IF REM BIT IS ON THEN DON'T DO REMOP SINCE POST
; WILL DO IT
PUSHJ P,REMOP ;REMOVE THE THING YOU'RE STACKING
MARTJ: MOVE SBITS,$SBITS(PNT);GET ITS BITS BACK FOR THE REST OF THIS
MARTH: POP P,FF ;RESTORE
POPJ P,
COMMENT MARK, MARKINT, MARKME -- Mark Semblk with Correct Temp Semantics
This marks the AC (D) with a temp descriptor of type in SBITS, TBITS
^^MARK: TRNE FF,PREMASK ;
PUSHJ P,[TRNE FF,657777
ERR <MARK>,1
JRST PRE]
PUSHJ P,MARK1
JRST POST ;ALL DONE.
MARK1: ANDI TBITS,MASK ;WANT ONLY THE TYPE BITS (NOT FORMAL,ETC.)
;;#NK# ! (1 OF 2) TEMPS SHOULD NOT HAVE DISPLAY LEVELS
TDZ SBITS,[CORTMP!PTRAC!INDXED!FIXARR,,DLFLDM]
;;#HS# JRL AN ITEMVAR IS NOT ITS DATUM
TRNE TBITS,ITMVAR!ITEM
JRST .+3
;;#HS#
TRNE TBITS,STRING ;IF STRING TYPE, THEN
JRST STMARK
TLO SBITS,INAC!ARTEMP!INUSE ;SINCE HE MAY NOT HAVE SET THEM.
TLZ SBITS,STTEMP
HRRE LPSA,ACKTAB(D) ;PICK UP TEMP DESCIRIPTOR
JUMPLE LPSA,NOTEM ;IF NO TEMP OR REMOPPED TEMP
MOVE USER,$SBITS(LPSA) ;GET SEMANTIC BITS
TLNN USER,INUSE ;A TEMP?
JRST REMM ;NO
TLNN USER,CORTMP ;A CORE TEMP?
JRST USOLD ;NO -- USE THE TEMP THAT IS THERE.
TLNE USER,INAC ;IS IT STILL IN THE ACCUMULATOR?
PUSHJ P,STORA ;YES --STORE IT.
SKIPA
REMM: PUSHJ P,CLEARL ;DO THE REMOP
NOTEM: PUSHJ P,GETTEM ;GET A NEW TEMPORARY
USOLD: HRRM LPSA,ACKTAB(D) ;INSERT IN AC TABLE RIGHT HALF
TLNN SBITS,PTRAC
TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
JRST .+3
TRNE TBITS,DBLPRC
JRST [
;;#YX# 3! JFR 2-10-77 SPURIOUS MESSAGE FOR X_-((Y+Z)+Z);
MOVE TEMP,ACKTAB(D)
CAMN TEMP,ACKTAB+1(D)
JRST .+1 ;ALREADY SAME, ASSUME RE-USE
SKIPE ACKTAB+1(D)
ERR <DRYROT MARK DOUBLE>,1
MOVEI TEMP,(D)
CAIE TEMP,RF-1 ;DO NOT CLOBBER RF!
HRRM LPSA,ACKTAB+1(D);SECOND AC OF DOUBLE
JRST .+1]
HRRM D,$ACNO(LPSA) ;AND THE LOGICAL INVERSE.
REC <
TRNE TBITS,PNTVAR ;A RECORD TEMP
TRNE TBITS,777777-(PNTVAR!GLOBL) ;
JRST MARKT ;NOPE
SKIPN TEMP,RCLASS ;BUG TRAP
ERR <DRYROT: RCLASS=0 WHEN TRYING TO MARK RECORD TEMP>,1
HRLM TEMP,$ACNO(LPSA) ;MARK IT
SETZM RCLASS ;
;FALL INTO MARKT
>;REC
MARKT: HRRZM LPSA,PNT ;
SETZM $VAL(PNT)
MARTS: POPJ P,
STMARK: TLO SBITS,STTEMP ;IN CASE IT SKIPS AND NOONE ELSE DID
TLZ SBITS,ARTEMP
HRRZ LPSA,PNT ;IN CASE STRTMP NOT CALLED
TLNN SBITS,INUSE ;ALREADY HAS A TEMP?
PUSHJ P,STRTMP ;GET A STRING TEMP.
JRST MARKT
DSCR MARKINT, MARKME
DES THESE ARE ROUTINES TO HELP YOU CALL "MARK"
MARKINT -- ALWAYS MARKS A VANILLA INTEGER, RETURNS DESCR. IN PNT,SBITS,TBITS.
MARKME -- YOU SPECIFY TBITS, SBITS=0 IS ASSUMED
;
^^MARKINT: MOVEI TBITS,INTEGR ;MARK AN INTEGR,
^^MARKME: HRRI FF,0
SETZ SBITS,
JRST MARK1
COMMENT INCOR -- Issue Code to Clear this Entity from ACs
DSCR INCOR
DES makes sure that the entity mentioned in PNT,TBITS,SBITS is really
in core. If not, the AC entry for that entity is cleared.
The updated Semantics bits are returned in SBITS.
;
^^INCOR:
TLZN SBITS,INAC!PTRAC ;GONE?
POPJ P, ;ALL DONE!
PUSH P,D ;SAVE THIS.
HRRZ D,$ACNO(PNT) ;PICK UP RELEVANT AC.
PUSHJ P,STORZ
POP P,D
JRST GETAD ;ALAS, SINCE STORZ WILL CHANGE THINGS.
COMMENT REMOPs, CLEARs -- Remove Temps, ACs, from Use
DSCR REMOP,REMOPA,REMOPL,REMOP2
DES These are the REMOP routines. They say, in effect, "I am
finished with this argument. If it was a temp descriptor, then I
am really finished, and the temp may be returned to the pool of
such temps. If it was a simple variable or constant, etc. then no
action is taken.
PAR The differences among the routines are only in the call form:
REMOP -- PNT has pointer to entity.
REMOPL -- LPSA has pointer to entity
REMOPA -- D has AC number of entity.
REMOP2 -- PNT2 has pointer to entity.
SID AC'S USED: LPSA,TEMP,USER
;
^REMOP2: MOVE LPSA,PNT2
JRST REMOPL
^REMOPA: SKIPA LPSA,ACKTAB(D) ;REMOP BY ACCUMULATOR NUMBER
^REMOP: MOVE LPSA,PNT ;OH WELL.
^REMOPL: TRNN LPSA,-1
POPJ P, ;NONE THERE.
MOVE TEMP,$SBITS(LPSA);THE STANDARD REMOP
TLNN TEMP,STTEMP!ARTEMP!INUSE ;A REAL TEMP?
JRST STCNST ;NO, CHECK IF A STRING CONSTANT
DELAL:
REC <
NORGC <
TLNN TEMP,INDXED
JRST DRFDON ;DONT HAVE TO DEREFERENCE IT
HRRZ USER,$VAL2(LPSA);WAS THIS GUY A RECORD SUBFIELD
JUMPE USER,DRFDON ;IF NOT, THEN NOTHING TO WORRY ABOUT
SKIPN USER,%RVARB(LPSA);UNLINK SELF FROM SUBFIELD CHAIN
ERR <DRYROT: REMOP OF SUBFIELD NOT ON SUBFIELD CHAIN>,1,SFULKD
TRNE USER,-1 ;ASS END OF CHAIN ?
HLLM USER,%RVARB(USER) ;NO, MAKE THE RIGHT GUY POINT AT MY LEFT
MOVS USER,USER ;NOW LINK THE OTHER WAY
HLRM USER,%RVARB(USER) ;MY LEFT POINTER NOW POINTS AT MY RIGHT
SETZM %RVARB(LPSA) ;TIDY UP
SFULKD: ;UNLINKING DONE NOW
HLLZS $VAL2(LPSA) ;MAKE SUBFIELD FLAG ZERO AGAIN
HLRZ USER,%TLINK(LPSA); WAS THIS THING HANGING RECD REF
CAIN USER,-1 ;IF SO,THIS IS -1
JRST DREFIT ;IT WAS, MUST DE-REFERENCE THIS ONE
PUSH P,USER ;I AM A SUBFIELD OF A FIELD
PUSHJ P,DRFDON ;KILL MYSELF OFF
POP P,LPSA ;THEN REMOP THE FIELD I HUNG OFF OF
JRST REMOPL ;
DREFIT:
SETZM $VAL(LPSA) ;SO THAT THE DEREF WORKS
PUSH P,A ;SAVE SOME ACS
PUSH P,C ;
PUSH P,PNT
PUSH P,TEMP
PUSH P,LPSA
;;#RY# MUST DO RECUUO ON AC, NOT (AC)
MOVE TEMP,$SBITS(LPSA)
MOVEI C,ARTEMP+INAC+INUSE
TLNE TEMP,CORTMP
TRC C,INAC+CORTMP
HRLM C,$SBITS(LPSA)
;;#RY#
MOVNI C,1 ;TO DO DEREFERENCING BY 1, SET C TO -1
MOVE PNT,LPSA ;THE THING TO DEREFERENCE
PUSHJ P,RFCADJ ;ADJUST REFERENCE COUNT
;**** NOTE: MAY BE SAFER TO PUT THESE
; ONTO SOME "HANG LIST" UNTIL STATEMENT LEVEL
; THIS IS BETTER, THOUGH, IF NOTHING BAD HAPPENS
POP P,LPSA ;RECOVER THESE FROM EARLIER
POP P,TEMP
POP P,PNT ;
POP P,C
POP P,A
DRFDON:
;; HERE CAN FALL INTO THE REST OF THE DELALL CODE. THIS WILL BE OK
;; SO LONG AS (1) DON'T SUFFER THE LOSSAGE I FEAR ABOUT ROUTINES ASSUMING
;; REMOP LEAVES PCNT THE SAME (ONE KLUGE WOULD BE TO SET A FLAG TO ALLOW
;; THE NEXT CALL TO ACCESS TO DO THE "RIGHT" THING, BUT UGH!
;; (2) THE CODE ABOVE ONLY GOBBLES THE SORT OF INDEXED TEMPS I EXPECT IT TO
;; IF NOT, MORE TESTING & MARKING IS REQUIRED
>;NORGC
RGC <
;;#WD# RHT 1-25-76 MAKE SURE THAT DEPENDENT TEMP TO STRING GOES, TOO.
MOVE USER,$TBITS(LPSA) ;
TLNE TEMP,INDXED ;INDEXED
TRNN USER,STRING!DBLPRC ;STRING, TOO
JRST RMP.00 ;NOPE
TDNE USER,[XWD SBSCRP,PROCED!ITEM!ITMVAR] ;EXCEPT FOR THESE
JRST RMP.00
HRRZ USER,$VAL2(LPSA) ;IS IT SUBFIELD
JUMPE USER,RMP.00 ;NO
PUSH P,LPSA ;SAVE STATE
PUSH P,TEMP ;
HLRZ LPSA,$ACNO(LPSA) ;HAVE WE A DEPENDENT?
SKIPE LPSA
PUSHJ P,REMOPL ;YUP, FLUSH HIM, TOO
POP P,TEMP
POP P,LPSA
JRST RMP.1 ;STRING SUBFIELD INDXED TEMPS
;DO NOT HAVE RECORDS AT ALL
RMP.00:
;;#WD# ^
TLNN TEMP,CORTMP ;ONLY CORTMPS ARE SPECIAL
JRST RMP.1 ;
TLNN TEMP,INDXED ;INDXED CORTMP??
JRST RMP.0 ;NOPE
HRRZ USER,$VAL2(LPSA) ;RECORD SUBFIELD??
JUMPE USER,RMP.1 ;NOPE
MOVSI USER,CORTMP!INUSE!ARTEMP;MAKE INTO A RECORD CORTMP
MOVEM USER,$SBITS(LPSA)
MOVEI USER,PNTVAR
MOVEM USER,$TBITS(LPSA) ;LIKE SO
JRST RMP.RC ;PUT IT ONTO THE RIGHT RING
RMP.0:
MOVE USER,$TBITS(LPSA) ;
TRNE USER,PNTVAR ;WAS IT A RECORD CORTMP
;;#VQ# ! RECORD ARRAYS ARE ALSO OK
;;[1] WASIDX is a kludge used to fix (we hope) bugs of the form
; recarr[n_n+1] _ recarr2[m_m+1] _ rec _ new!record
;Initially the address of element recarr2[m] is stored in a temp. This
;sets INDXED in SBITS. However when the leftmost assignment is done, the
;value of the element is loaded into the AC (although never put into the
;temp), causing INDXED to be cleared, since the AC is now a value. The
;problem is that the code on this page then believes that the temp is
;a normal record pointer, since INDXED is no longer on in SBITS. Eventually
;a descriptor is put into the procedure descriptor asserting that this is
;the case. The record GC then ends up trying to GC the temp, with disasterous
;results, since the temp is really not a record pointer at all. This fix is
;to set WASIDX in TBITS whenever INDXED is set. WASIDX does not get cleared
;when INDXED does. If WASIDX is on, we conclude that the temp we are looking
;at is this case, and that it is really an address. So we don't do anything
;to it. This is a heuristic. If SAIL should ever store the actual record
;pointer back into the same temp, we would be in big trouble. It is very
;hard to know whether this will happen or not. If it does, somebody is going
;to have to find a way to generate a separate temp for the array address
;and the record pointer.
TDNE USER,[XWD WASIDX!SBSCRP,ITEM!ITMVAR] ;[1] THESE ARE OK
JRST RMP.1 ;NOPE
RMP.RC:
;;%##% BUG TRAP
HRRZ USER,RCTEMP ;WAS THIS GUY ALREADY ON THE CHAIN
JUMPE USER,RMP.0R ;NO CHAIN
CAIN USER,(LPSA) ;WELL?
ERR <DRYROT: RECORD CORTMP REMOP>,1
HRRZ USER,(USER) ;CHAIN
JUMPN USER,.-3
RMP.0R: ;;%??% INSERTED HERE BY JFR 11-16-75
;;%##% ^
HRRZ USER,LPSA ;
EXCH USER,RCTEMP ;
HRRZM USER,%TLINK(LPSA) ;REMEMBER IT AS AN AVAILABLE
JRST IACCHK ;RECORD TEMP
;(NOTICE THAT INUSE WAS LEFT ON)
RMP.1:
>;RGC
>;REC
MOVSI USER,INUSE!STTEMP!INAC!PTRAC!NEGAT!FIXARR ;TURN THESE OFF
ANDCAM USER,$SBITS(LPSA) ;IN MEMORY.
IACCHK: HRRZ USER,$ACNO(LPSA) ;GET THE AC IT WAS IN
TLNN TEMP,INAC!PTRAC ;WAS IT IN AN AC?
JRST CTCHK ;NO -- ALL DONE.
SKIPGE ACKTAB(USER) ;YES --TURN IT OFF.
ERR <DRYROT -- REMOP>,1
SETZM ACKTAB(USER)
TLNN TEMP,PTRAC
TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
JRST .+3
TRNE TBITS,DBLPRC
JRST [CAIN USER,RF-1
ERR <DRYROT IACCHK>,1
CAIE USER,RF-1
SETZM ACKTAB+1(USER)
JRST .+1]
CTCHK: TLNE TEMP,INUSE ;If this was still an alive temp, and
TLNE TEMP,CORTMP ; was not a CORTMP, thus contains no fixups
POPJ P, ; or anything, we can release it to free
PUSH P,LPSA ; storage. Otherwise, leave it on the TTEMP
PUSHJ P,BLKFRE ; list (where it MUST be), and forget it.
POPJ P,
STCNST: MOVE TEMP,$TBITS(LPSA) ;
TLNE TEMP,CNST ;
TRNN TEMP,STRING ;
POPJ P, ; RETURN IF NOT A STRING CONSTANT
MOVE TEMP,$PNAME(LPSA) ; CHECK IF TRYING TO REMOP NULL STRING WHICH IS
TRNN TEMP,-1 ; ONLY STRINS'ED ONCE
POPJ P, ; YES, DON'T REMOP
SOSLE TEMP,$VAL2(LPSA) ; DECREMENT REFERENCE COUNT AND GET OUT IF NOT
POPJ P, ; ZERO
JUMPE TEMP,.+2 ; ZERO COUNT?
ERR <DRYROT REMOP:STCNST> ;
SKIPN $VAL(LPSA) ; USED IN PRELOAD?
SKIPE $ADR(LPSA) ; USED IN FIXUP?
POPJ P, ; YES, RETURN
PUSHJ P,URGCST ; REMOVE FROM STRING CONSTANT RING
PUSHJ P,URGSTR ; REMOVE FROM STRING RING
PUSH P,PNAME ; SAVE PNAME AND PNAME+1 (OK ON P STACK SINCE NO
PUSH P,PNAME+1 ; GARBAGE COLLECTION CAN HAPPEN)
HRROI TEMP,$PNAME+1(LPSA) ; GET STRING DESCRIPTOR FOR HASH LOOKUP SO THE
POP TEMP,PNAME+1 ; STRING CAN BE REMOVED FROM THE HASHED SYMBOL
POP TEMP,PNAME ; TABLE
PUSH P,TBITS ; SAVE AC'S WHICH SHASH WILL DESTROY
PUSH P,A ;
PUSH P,B ;
PUSH P,C ;
PUSH P,D ;
PUSH P,PNT ;
PUSH P,LPSA ;
MOVE LPSA,STRCON ; USE STRING HASH TABLE
PUSHJ P,SHASH ;
MOVE B,HPNT ; INSTRUCTION TO LOAD FIRST IN CONFLICT LIST
XCT B ; FIRST IN CONFLICT LIST INTO LPSA
HRRZ PNT,(P) ; THE ONE WE ARE LOOKING FOR
MOVEI A,LPSA ;
SCOMLP: HRRZ TEMP,(A) ; CANDIDATE?
JUMPE TEMP,ERRSTC ; NOT THERE - ERROR
CAMN TEMP,PNT ;
JRST SFNDIT ;
MOVE A,TEMP ; CHAIN DOWN CONFLICT LIST
JRST SCOMLP ;
SFNDIT: HRRZ TEMP,(TEMP) ; NEXT IN LIST
HRRM TEMP,(A) ; CHAIN AROUND DELETED ELEMENT
TLO B,2000 ; CHANGE FROM LOAD TO STORE
XCT B ;
FREBLK (PNT) ;
POP P,LPSA ; RESTORE AC'S
POP P,PNT ;
POP P,D ;
POP P,C ;
POP P,B ;
POP P,A ;
POP P,TBITS ;
POP P,PNAME+1 ;
POP P,PNAME ;
POPJ P, ;
ERRSTC: ERR <DRYROT AT REMOP>,1 ;
DSCR CLEAR,CLEARL,CLEARA
DES These are routines to clear an entry in the AC table (ACKTAB)
That is, all memory of what is in the AC is lost. The difference
among the routines is the call form:
PAR CLEAR -- PNT has pointer to entity to be "cleared"
If it turns out not to be in an AC, no action is taken.
CLEARL -- LPSA has pointer; same deal.
CLEARA -- D has AC number to be cleared.
SID AC'S USED: LPSA,TEMP
;
^CLEAR: MOVEI LPSA,(PNT) ;CLEAR OUT AN AC TABLE ENTRY.
^CLEARL: MOVE TEMP,$SBITS(LPSA) ;SEE IF IT IS IN AN AC.
TLNN TEMP,INAC!PTRAC ;IF NOT -- ALL DONE.
POPJ P, ;DONE.
MOVE TEMP,$ACNO(LPSA) ;AC IT IS IN.
;;#YJ# 2! JFR 1-13-77 QUIT IF NOTHING THERE
SKIPN ACKTAB(TEMP)
JRST CLR1
SETZM ACKTAB(TEMP) ;AND ZERO THE ENTRY.
MOVE TEMP,$SBITS(LPSA)
TLNE TEMP,PTRAC
JRST CLR1 ;POINTERS ARE NOT LONG
MOVE TEMP,$TBITS(LPSA)
TDNN TEMP,[SBSCRP,,PROCED!ITEM!ITMVAR] ;LEAP IS NOT LONG
TRNN TEMP,DBLPRC ;LONG?
JRST CLR1 ;NO
HRRZ TEMP,$ACNO(LPSA);YES, REFETCH AC
JRST CLR2
^CLEARA:
SKIPN LPSA,ACKTAB(D)
POPJ P, ;NOTHING THERE
CAMN LPSA,ACKTAB-1(D) ;POSSIBLE DBLPRC SCREWUP?
SOJA D,[PUSHJ P,CLEARA ;YES, CLEAR FIRST AC INSTEAD
AOJA D,CPOPJ] ;RESTORE D
SETZM ACKTAB(D) ;ZERO AC TABLE ENTRY
MOVE TEMP,$SBITS(LPSA)
TLNE TEMP,PTRAC
JRST CLR1 ;POINTERS ARE NOT LONG
MOVE TEMP,$TBITS(LPSA)
TDNE TEMP,[SBSCRP,,PROCED!ITEM!ITMVAR]
JRST CLR1
TRNE TEMP,DBLPRC ;DOUBLE?
JRST [MOVEI TEMP,(D)
CLR2: HLL LPSA,ACKTAB+1(TEMP) ;MAKE COMPARISON ON RIGHT HALF ONLY
CAIE TEMP,RF-1 ;MAKE THIS IRON-CLAD
CAME LPSA,ACKTAB+1(TEMP);NEXT AC SHOULD BE SAME
ERR <DRYROT CLEAR DOUBLE>,1
CAIE TEMP,RF-1
SETZM ACKTAB+1(TEMP) ;CLEAR SECOND AC
JRST .+1]
CLR1: MOVSI TEMP,INAC!PTRAC!NEGAT
TRNE LPSA,-1 ;ANYTHING THERE? (DCS -- 8/16/70)
ANDCAM TEMP,$SBITS(LPSA) ;TURN THESE OFF IN MEMORY.
POPJ P,
COMMENT STROP -- Bit-Driven String Operation Code Generator
DSCR STROP
DES This routine is willing to do lots of twiddling on strings.
It knows about reference strings, etc.
PAR A is an instruction for the EMITTER, with some bits in
it to say what things should be done with this instruction.
Bits in A: bpword -- issue the instruction for
the byte pointer word.
lnword -- or for the length word.
bpfirst -- issue the byte pointer inst. first.
adop -- this is an instruction which adds to stack.
sbop -- this is an instruction which subs from stack.
undo -- so a SUB SP,X22 at end.
rem -- do a remop when done.
stak -- used internally.
bpinc -- byte pointer instruction is in c(rh)
PNT,TBITS,SBITS -- semantics of string.
D -- accumulator to use for ac field of op.
Thus, it must be RSP if that stack is to be used.
;
^STROP: CAIN D,RSP ;IF THE STACK,
TRO A,STAK ;THEN MARK AS SUCH.
DPB D,[POINT 4,A,12] ;SAVE IN AC FIELD OF INSTRUCTION.
PUSHJ P,ACCOP ;AND GET ACCESS TO THE ROUTINE.
;THIS UPDATES SBITS IN CORE.
STROP1: PUSH P,ACKTAB(D) ;PROTECT.
SETOM ACKTAB(D)
PUSH P,D ;SAVE AC.
TLNN TBITS,REFRNC ;THE HARD CASE.
JRST OPPP1 ;
PUSH P,A ;SINCE GETOPE DOES NOT PRESEVE.
HRRI FF,ADDR!INDX
PUSHJ P,GETOPE ;GET THE ADDRESS OF THE BP WORD IN AN AC.
;THIS UPDATES SBITS IN CORE.
SETZM ACKTAB(D) ;WE DO NOT WANT TO SEE THIS AGAIN.
HRLZS D ;READY FOR INDEXING.
POP P,A
OPPP1: TLNE SBITS,STTEMP ;IF STACKED, THEN NEED
HRLI D,RSP ;THE STACK
HRRI FF,(A) ;SAVE BITS.
TRNE FF,BPFIRST ;IF BYTE POINTER WORD FIRST, DO IT
PUSHJ P,BP
PUSHJ P,LN ;NOW THE LENGTH
TRNN FF,BPFIRST
PUSHJ P,BP
TRNE FF,UNDO
TLNN SBITS,STTEMP ;IF UNDO AND A STACKED STRING.
JRST OP2 ;
PUSHJ P,SUBIT
OP2: POP P,D ;RESTORE.
POP P,ACKTAB(D)
TRNE FF,REM ;IF REMOP ASKED FOR.
JRST REMOP
POPJ P, ;ALL DONE.
DSCR SUBIT
DES Emits a SUB SP,[XWD 2,2], and subtracts two from SDEPTH.
;
^SUBIT:
;;%DN% JFR 7-2-76
;; PUSH P,A
MOVNI A,2
ADDM A,SDEPTH
HRLI C,-2
JRST ESPADJ
;; MOVE A,X22 ;SUBTRACT TWO FROM THE STACK.
;; PUSH P,PNT
;; PUSHJ P,CREINT
;; EMIT (<SUB RSP,NOUSAC>) ;THEN ISSUE THE SUBS.
;; PUSHJ P,REMOP ;JUST IN CASE
;; POP P,PNT
;; MOVNI A,2
;; ADDM A,SDEPTH ;UPDATE COUNT.
;; POP P,A
;; JRST GETAD ;RESTORE TBITS,SBITS.
;;%DN% ^
BP: TRNN FF,BPWORD ;ONLY IF ASKED FOR.
POPJ P,
PUSH P,A ;SAVE
TRNE FF,BPINC ;IF ANOTHER INSTRUCTION AROUND.
DPB C,[POINT 9,A,8] ;IN INSTRUCTION PARTS.
HRRI A,NOUSAC!FXTWO ;TENTATIVE BITS TO EMITER.
TLNN SBITS,STTEMP ;IF ON STACK OR
TLNE TBITS,REFRNC ;BUT IF THIS CASE, THEN
TRC A,FXTWO!NORLC!USX!USADDR
HRLI C,0 ;WITH NO DISCPLACEMENT.
PUSHJ P,EMITER
POP P,A
JRST FINBP
LN: TRNN FF,LNWORD ;ONLY IF ASKED
POPJ P,
HRRI A,NOUSAC
TLNN SBITS,STTEMP ;IF TEMP OR
TLNE TBITS,REFRNC ;REFERENCE, THEN MUST USE
TRO A,NORLC!USX!USADDR ;INDEXING ETC.
HRLI C,-1 ;ANO THIS TIME A DISPLACEMENT.
PUSHJ P,EMITER
FINBP: TRNE FF,ADOP!SBOP ;PREPARE TO ADJUST STACK.
TRNN FF,STAK ;ONLY IF ON STACK.
POPJ P, ;NONE.
TRNE FF,ADOP
AOSA SDEPTH
SOS SDEPTH ;OUR BOOKKEEPING DONE,
POPJ P, ;WE DEPART.
;;%DN% JFR 7-4-76
DSCR EADJSP, EPADJ, ESPADJ
DES Emits instruction to alter stack depth
PAR LH(C) proper constant for ADJSP
RH(D) stack ac for EADJSP.
RES ADJSP emitted if allowed, else proper ADD or SUB
SID A, TEMP clobbered. PNT,TBITS,SBITS saved
;
^EADJSP:MOVEI TEMP,(D) ;AC
CAIE TEMP,RP ;FIGURE OUT WHICH STACK
^ESPADJ:SKIPA A,[ADJSP RSP,NOUSAC!USADDR!NORLC]
^EPADJ: MOVE A,[ADJSP RP,NOUSAC!USADDR!NORLC]
MOVE TEMP,ASWITCH
TRNE TEMP,AADJSP
JRST EMITER ;EASY WAY
PUSH P,PNT ;SAVE THIS GUY
PUSH P,TBITS
PUSH P,SBITS
JUMPL C,.+2 ;FIGURE OUT ADD OR SUB
TLCA A,(<ADJSP><ADD>)
TLC A,(<ADJSP><SUB>)
TRZ A,USADDR!NORLC
PUSH P,A ;SAVE INSTR FOR LATER
HLRE A,C ;COMPUTE CONSTANT
MOVM A,A
HRLI A,(A)
PUSHJ P,CREINT ;MAKE AN XWD
POP P,A ;GET INSTR BACK
PUSHJ P,EMITER ;PUT OUT INSTR, PNT POINTS TO XWD
POP P,SBITS
POP P,TBITS
POP P,PNT ;GET IT BACK
POPJ P,
;;%DN% ^
COMMENT GETTEM, etc. -- Temp Semblk Allocators
DSCR GETTEM,GETCRTMP,STRTMP
DES Routines for getting temp descriptor Semblks. The list of
free temps is searched for an appropriately free one. If found,
a masked form of TBITS, and a masked form of SBITS are stored
in the Semblk for this temp. A pointer to it is returned in LPSA
INCL more descriptions about temps, their numbers, how they're
moved, kept track of, deleted, depend on procedures, etc.
GETTEM -- get a non-core temp
STRTMP -- get a String temp (i.e. turn on the STTEMP bit in SBITS)
GETCRTMP -- get a core temp.
SID AC'S USED: USER,LPSA,TEMP
;
STRTMP: TLOA SBITS,INUSE!STTEMP
^GETTEM: TLO SBITS,INUSE!ARTEMP ;TURN ON TEMP BITS.
;;#NK# ! (2 OF 2) TEMPS SHOULD NOT HAVE DISPLAYS LEVELS
TDZ SBITS,[CORTMP,,DLFLDM]
GETBLK ;GET A NEW BLOCK
GTT1: MOVEM SBITS,$SBITS(LPSA)
ANDI TBITS,MASK
MOVEM TBITS,$TBITS(LPSA) ;GOOD BITS IN MEMORY
POPJ P, ;NOTHING ELSE TO DO
^GETCRTMP: ;GET A CORE TEMP
SKIPA LPSA,TTEMP
STRG: LEFT ,%RVARB,NOFF
MOVE TEMP,$SBITS(LPSA)
TLNE SBITS,CORTMP
TLOE TEMP,INUSE
JRST STRG
TLNE SBITS,PTRAC
JRST DDRET ;POINTERS ARE NOT LONG
TDNN TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
TRNN TBITS,DBLPRC
JRST DDRET ;NOT DBL
MOVE TEMP,$TBITS(LPSA)
TDNN TEMP,[SBSCRP,,PROCED!ITEM!ITMVAR]
TRNN TEMP,DBLPRC
JRST STRG ;NEED DBL TEMP FOR DBL QTY
DDRET: MOVSI SBITS,INUSE!CORTMP!ARTEMP
JRST GTT1 ;FINISH OUT AS ABOVE.
NOFF: PUSHJ P,GETTEM
AOS TEMP,TEMPNO ;INCREMENT TEMP ID NO
MOVEM TEMP,$PNAME(LPSA) ;STORE IN $PNAME FOR ADCON AND SCOUT
SETZM $ADR(LPSA) ;AND ZERO THE FIXUP.......
PUSHJ P,RNGTMP
JRST DDRET
RGC <
^GETRCT:SKIPE SIMPSW ;SIMPLE PROCEDURE??
ERR <ATTEMPT TO CREATE A RECORD TEMP INSIDE A SIMPLE PROCEDURE>,1
HRRZ LPSA,RCTEMP ;GET NEXT OFF RECORD TEMP CHAIN
JUMPE LPSA,GRCT.1 ;NONE THERE
HRRZ TEMP,%TLINK(LPSA);
MOVEM TEMP,RCTEMP
POPJ P,
GRCT.1: GETBLK
PUSHJ P,RNGTMP
AOS TEMP,TEMPNO
MOVEM TEMP,$PNAME(LPSA)
MOVSI TEMP,ARTEMP!INUSE!CORTMP
MOVEM TEMP,$SBITS(LPSA)
MOVEI TEMP,PNTVAR
MOVEM TEMP,$TBITS(LPSA)
POPJ P,
>;RGC
COMMENT GETAC, GETAN0 -- AC Allocators
DSCR GETAC,GETAN0
DES These are the "get a free AC routines".
PAR FF(rh) -- two modifier bits:
DBL -- get a double AC (i.e. next one free too)
INDX -- get an indexable AC (not 0 or 1 -- 1 is avoided since
Procedures tend to return values in 1).
RES in D is returned the free (first free) AC number
Note that no ACKTAB marking has been done yet, so the AC
need not be used.
GETAN0: same as GETAC, but INDX is autimatically turned on.
AC'S USED: TEMP,LPSA
;
^GETAN0: TRO FF,INDX ;HERE IF YOU DON'T WANT TO SET THE BIT
^GETAC:
HRR D,ACKPNT ;LAST AC USED
SETOM ACKPNT ;CLEAR IT
SETZM POSSIB ;MASK OF POSSIBILITIES
MOVNI TEMP,20 ;NUMBER OF AC'S TO SEARCH
;;#HF# 5-13-72 DCS RETURN OLDEST AVAILABLE AC IF NONE FREE, FIX DBL
GET1: AOJG TEMP,GET7 ;For each AC, starting with the one
ADDI D,1 ; after the last allocated, and wrapping
TRZ D,777760 ; around to 0 (2 if GETAN0), if the AC
TRNE FF,INDX ; is not protected (ACKTAB(AC)<0),
TRNE D,-2 ; record the (oldest) first one seen in
SKIPGE LPSA,ACKTAB(D) ; ACKPNT -- if the entry is free (0),
JRST GET1 ; try to terminate. Otherwise, continue
SKIPGE ACKPNT ; looking for a free one.
HRRZM D,ACKPNT
TRNN LPSA,-1
JRST GET4
JRST GET1
; ONE FREE ONE EXISTS -- JUST RECORD IF DBL (NEED TWO)
GET4: TRNN FF,DBL ;If only one AC is needed, it's number
JRST DSTORZ ; is in D.
GET3: MOVEI LPSA,1 ;Otherwise, record its number in the
LSH LPSA,(D) ; bit array POSSIB. This is not the
IORM LPSA,POSSIB ; most efficient method, but it allows
JRST GET1 ; the fun below.
; LIST EXHAUSTED -- TAKE WHAT WE COULD GET
GET7: TRNE FF,DBL ;If two were needed, we must work
JRST GET9 ; harder.
; TAKE A DISPLAY TEMP FIRST
SKIPE DISLST ;ONLY ANY GOOD IF HAVE SOME
SKIPG LPSA,CDLEV ;CURRENT DISPLAY LEV
JRST GET7.1
HRRI D,1 ; COULD NEVER BE ZERO OR 1
GET7.2: SKIPE DISTAB(D)
JRST GET7.3 ;THIS THING HAS AN AC
AOS D ;TRY THE NEXT ONE UP
SOJG LPSA,GET7.2
ERR <DRYROT AT GETAC> ;YOU REALLY BLEW IT, SAM
GET7.3: MOVE LPSA,DISTAB(D) ;PICK IT UP
TLNE LPSA,-1 ;USE STRING DISPLY IF WE CAN
MOVSS LPSA ;US STRING -HURRAH
CAIN LPSA,RF ;
JRST GET7.1 ;IF RF, THEN NO GO
HRR D,LPSA ;WE CAN GRAB THIS ONE
SKIPG ACKTAB(D)
ERR <GETAC GRABBED SAFE AC -- DRYROT AND WORMS>
JRST DSTORZ ;RECORD IT, CLEAR IT OUT
GET7.1:
; NO DISPLAY TEMP, CLEAR SOMETHING ELSE OUT AND USE IT.
HRR D,ACKPNT ;Use the first one recorded, which
JRST STORZ ; is also the oldest found
; WE NEED TWO -- TRY FOR TWO UNUSED IN A ROW
GET9: MOVE LPSA,POSSIB ;If any two in a row were free,
LSH LPSA,1 ; the AND of the bits and 2*bits
AND LPSA,POSSIB ; will yield a bit for each pair.
JUMPE LPSA,G10 ;No bits implies no pairs.
FSC LPSA,231 ;The FSC shifts the first match
LDB LPSA,[POINT 4,LPSA,8] ; to a normalized position, and
MOVEM LPSA,ACKPNT ; records its index in the exponent
HRR D,LPSA ; field.
POPJ P,
G10: HRRI D,21 ;As a last resort, take the first
G11: SUBI D,2 ; two unprotected ACs available.
TRNE D,777000 ;If none are found, complain bitterly.
ERR <DRYROT AT DBL GETAC> ;This could be improved by
SKIPL LPSA,ACKTAB(D) ; looking for the oldest pair, and/or
SKIPGE ACKTAB-1(D) ; a pair with one free AC, but at
JRST G11 ; this point, we're sort of beyond
JUMPE LPSA,.+2 ; caring.
PUSHJ P,STORZ ;Store the second, if it needs it.
SUBI D,1 ;This is the result.
DSTORZ: HRRZM D,ACKPNT ;Allocating this one. Now go make
JRST STORZ ; sure it's ready for new action.
;;#HF#
COMMENT AC Store routines -- BOLSTO, FORSTO, STORIX, GOSTO, STORZ
DSCR BOLSTO
DES Special Boolean store. It does not remove from ACs any
of the arguments to the Boolean compare.
PAR PNT and PNT2 must point to Semantics of the two arguments.
RES All other ACs are stored. The Semantics of the parameters
are not necessarily guaranteed over the call, since either
may have been marked for storing.
SEE STORZ, which it calls for each AC cleared
;
^BOLSTO: PUSH P,[PUSHJ P,[
HRRZ TEMP,LPSA
CAIE TEMP,(PNT2)
CAIN TEMP,(PNT)
POPJ P,
JRST STORZ]] ;DO TURN OFF ACSAME FOR THESE GUYS.
; THIS STORZ IS NEEDED BECAUSE A PARTICULAR BOOLEAN MAY LOOK LIKE:
; MOVE 4,I
; SKIPN J
; JRST FOO1
; MOVE 4,J+K
; SKIPE GH
; JRST SHIT
;FOO1: ..... HERE THE COMPILER THINKS J+K IS IN 4, WHERE I MIGHT BE!!!
;
JRST GG0
DSCR FORSTO
DES Special AC dumper for FOR Loops. This protects the index
AC from being cleared. Other variables are not cleared, just
stored if temps.
PAR PNT and PNT2 should point to anything to be preserved
over this operation (e.g. FOR I_ <EXP> STEP .... want to preserve
I and the Semantics of <EXP> from storing before the test.
SEE STORA, which it calls for each AC stored.
;
^FORSTO: PUSH P,[PUSHJ P,[HRRZ TEMP,ACKTAB(D) ;FOR FOR LOOPS.
CAIE TEMP,(PNT)
CAIN TEMP,(PNT2)
POPJ P,
;DCS -- 8/16/70
PUSHJ P,STORA ;STORE IT FOR SURE
JUMPE LPSA,NSBSC ;NOTHING TO CLEAR
;;#MU# RHT 6-25-73 I THINK THE FOLLOWING DISTINCTION IS POINTLESS
; MOVE TEMP,$TBITS(LPSA) ;IF AN INAC ARRAY,
; TLNE TEMP,SBSCRP ;CLEAR IT, BECAUSE WILL
;;#MU#
JRST CLEARL ;STILL BE ASSUMED INAC AT
NSBSC: POPJ P, ; LOOP TOP OTHERWISE
]] ;DCS -- 8/16/70
JRST GG0
DSCR STORIX
DES "Store" all INTERNALs and EXTERNALs, i.e. forget that
they are in ACs.
;
^STORIX: PUSH P, [PUSHJ P,[
HRRZ LPSA,ACKTAB(D)
JUMPE LPSA,CPOPJ ;NOTHING THERE.
MOVE LPSA,$TBITS(LPSA)
TLNE LPSA,INTRNL!EXTRNL
JRST CLEARA
POPJ P,]]
JRST GG0
DSCR ALLSTO
DES Dump all ACs in the most permanent of ways. Do not
retain any marking of the AC's at all.
SEE STORZ, which it calls for each AC gronked.
;
^ALLSTO:OPTSYM %ALSTO
PUSH P,[PUSHJ P,STORZ] ;TO CLEAR INAC" BITS.
SKIPA
DSCR GOSTO
DES Store any AC's marked with temps (as opposed to variables).
Leave the AC markings as they are.
Storing in forward direction makes life easier for LONG (double) things.
;
^GOSTO: PUSH P,[PUSHJ P,STORA]
GG0: PUSH P,D
MOVSI D,-20 ;D, WHO WILL HAVE A COUNT
SKIPLE LPSA,ACKTAB(D) ;DO WE HAVE A STORE TO DO?
XCT -1(P) ;EXECUTE STORING ROUTINE.
AOBJN D,.-2
ALLD: POP P,D
POP P,(P) ;THROW AWAY
POPJ P, ;AND RETURN
DSCR STORZ
DES "Store" this AC and wipe out the ACKTAB entry -- clear
INAC-type SBITS in the Semantics which were there.
PAR AC # in D
SEE STORA,CLEARA routines, which it calls
;
^STORZ: PUSHJ P,STORA
JRST CLEARA
COMMENT STORA -- main AC-storing subr. -- called by above
DSCR STORA
DES Stores temp results that are in a specified AC into
a core temp. If a temp exists in that AC, an appropriate core
temp is found, and the Stoe is EMITted.
Then the SBITS word in the Semantics is updated to
reflect the "In Core" status (e.g. CORTMP bit, fixup
chain addr, etc.) The fixup chain may have originated
in another temp entry, but was moved here to avoid searching
up the Semantic stack for all who refer to this temp and
changing the addresses of the entry they point to. WHAT????
PAR D contains AC # affected.
SID LPSA, TEMP used
;
^STORA: SKIPG LPSA,ACKTAB(D)
POPJ P, ;NOTHING THERE.
CAMN LPSA,ACKTAB-1(D) ;POSSIBLE DBLPRC SCREWUP?
SOJA D,[PUSHJ P,STORA ;YES, STORE PRECEDING AC INSTEAD
AOJA D,CPOPJ] ;AND RESTORE D
PUSH P,SBITS
PUSH P,TBITS ;SAVE YET ANOTHER AC
MOVE SBITS,$SBITS(LPSA);GET SEMANTIC BITS.
TLNN SBITS,INAC!PTRAC ;IF NOT IN AC, THEN TROUBLE
ERR <STORA A THING NOT IN AC>,1
;; #KQ BY JRL (11-30-72) IGNORE FIXARS
TLNN SBITS,FIXARR ;A FIXARR SHOULDN'T GET STORED
TLNN SBITS,ARTEMP!DISTMP ;OTHERWISE A NOOP
JRST ZER
PUSH P,PNT
PUSH P,A
MOVEI PNT,(LPSA)
;BUG TRAP
HRRZ TEMP,$ACNO(PNT) ;THIS IS THE AC IT THINKS ITS IN.
CAIE TEMP,(D) ;THE SAME
ERR <STORA>,1
TLNE SBITS,DISTMP ;DISPLAY????
JRST ZERDR ;YES
TLNE SBITS,CORTMP ;CAN WE PUT IT WHERE WE PUT IT BEFORE?
JRST DEP ; YES (USUALLY ONLY HAPPENS WHEN SOME
; BUG PROVOKES IT --LIKE MISSING REMOP)
RGC <
TLNN SBITS,INDXED ;IF NOT INDXED TEMP
JRST RCTCHK ;GO CHECK IF RECORD TEMP
HRRZ TEMP,$VAL2(PNT) ;A SUBFIELD INDXED TEMP??
JUMPE TEMP,NRML ;NO, JUST TREAT NORMALLY
;;#WX# ! JFR 6-5-76 FORGOT TO FETCH TBITS
MOVE TBITS,$TBITS(PNT)
;;#WD# STRING SUBFIELD INDXED TEMPS ARE SPECIAL
TDNN TBITS,[XWD SBSCRP,PROCED!ITEM!ITMVAR]
;;#WW# ! JFR 6-1-76 used to be TRNE (typo)
TRNN TBITS,STRING
JRST RCTMAK ;YES, DO THE OTHER SORT OF MOVEM
JRST NRML ;HERE IF STR SUBF INDX TEMP
;;#WD# ^
RCTCHK: MOVE TBITS,$TBITS(PNT)
TRNN TBITS,ITEM!ITMVAR ;THESE ARE ALWAYS NORMAL
TRNN TBITS,PNTVAR ;A RECORD TEMP
JRST NRML ;NOPE NORMAL
RCTMAK: PUSHJ P,GETRCT ;GET A PNTVAR CORTMP
JRST TMPCPY ;GO COPY FIXUPS,ETC
NRML:
>;RGC
SKIPA LPSA,TTEMP ;PREPARE TO SEARCH TEMP LIST
TEML: LEFT ,%RVARB,NOFND ;GO DOWN TEMP LIST
MOVE TEMP,$SBITS(LPSA)
TLZE TEMP,INUSE ;NEED ONE NOT IN USE
JRST TEML
TLZN TEMP,CORTMP ;AND IN CORE
JRST TEML ;REALLY AN ERROR
TMPCPY: MOVE TEMP,$ADR(LPSA)
MOVEM TEMP,$ADR(PNT) ; HO HO.
MOVE TEMP,$PNAME(LPSA) ;ID NUMBER OF THIS CORTMP
MOVEM TEMP,$PNAME(PNT) ;SO ADRINS AND SCOUT DON'T GET CONFUSED
PUSHJ P,URGTMP ;REMOVE FROM RING
FREBLK () ;THE OLD ONE
JRST DEP1
NOFND: SETZM $ADR(PNT) ;WITH ZERO FIXUP
;; #JRL ALWAYS GIVE CORTMPS ID NO.
AOS TEMP,TEMPNO ;CORTMP ID
MOVEM TEMP,$PNAME(PNT)
;; #JRL
DEP1: MOVE LPSA,PNT
PUSHJ P,RNGTMP ;PUT ON RING
DEP: MOVSI SBITS,CORTMP!INUSE!ARTEMP
IORB SBITS,$SBITS(PNT) ;INDICATE THE NEW STATUS
TURNOF: MOVSI LPSA,INAC!PTRAC!NEGAT ;TEMP NO LONGER IN AC
ANDCAM LPSA,$SBITS(PNT)
HRRM D,$ACNO(PNT) ;RECORD THE AC NUMBER
HRLZI A,(<MOVEM>)
TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
JRST .+3
TRNE TBITS,DBLPRC
MOVSI A,(<DMOVEM>)
TLNE SBITS,INDXED ;A CALCULATED SUBSCRIPT?
TRO A,ADDR ;YES -- DO NOT STORE INDIRECT.
TLNE SBITS,NEGAT ;IS THE AC AROUND NEGATIVELY?
JRST [HRLI A,(<MOVNM>) ;YES
TRNE TBITS,DBLPRC
HRLI A,(<DMOVNM>)
JRST .+1]
;; #MD# ONLY STORE RIGHT HALF OF PTRAC
TLNE SBITS,PTRAC
HRLI A,(<HRRZM>) ;ONLY RIGHT HALF, IN CASE LATER AN
;INDIRECT MOVE IS DONE
PUSHJ P,EMITER
;NOTE THOUGH THAT NEGAT MAY STILL
;BE ON. THIS MAY BE DANGEROUS.
MOVEM SBITS,$SBITS(PNT)
ZRET: POP P,A
POP P,PNT
ZER:
POP P,TBITS
POP P,SBITS
POPJ P, ;RETURN
ZERDR: MOVE A,$VAL(PNT) ;ZEROING MASK
HRR LPSA,$ADR(PNT) ;PICK UP DISPLAY LEVEL
ANDM A,DISTAB(LPSA) ;ZERO APPROPRIATE SIDE OF DISTAB WORD
HLLZS ACKTAB(D) ;ZONK THE ACKTAB ENTRY
MOVE LPSA,PNT
PUSHJ P,URGDIS ;UNLINK FROM DISPLAY VARB RING
FREBLK (PNT)
JRST ZRET
SUBTTL CODE EMITTER
COMMENT EMITER -- Descriptions of Routine and Control Bits
DSCR EMITER -- code emitting routine.
DES From input parameters and symbol table information,
generate a word of real live code.
PAR
A -- OPCODE in LH, bits in RH:
NOUSAC__400000 ;DON'T USE D(RH) AS AC #
USCOND__200000 ;USE C(RH) AS 3 BITS OF CONDITION
USADDR__100000 ;USE C(LH) AS DISPLACEMENT PART
USX __ 40000 ;USE D(LH) AS INDEX REG
NORLC __ 20000 ;RELOCATE NOT!
IMMOVE__ 10000 ;IF OPERAND CONSTANT, LOAD IT ANY WAY POSSIBLE
INDRCT__ 4000 ;INDIRECT ADDRESSING REQUIRED
JSFIX __ 2000 ;JUST DO A FIXUP (DON'T GET SEMANTICS).
NOADDR__ 1000 ;NO EFFECTIVE ADDRESS PART
ADDR __ 400 ;WE WANT THE ADDRESS OF THIS ENTITY
FXTWO__ 100 ;USE SECOND FIXUP WORD
C -- DISPLACEMENT (if provided) in LH, condition bits in RH
D -- Index number in LH, AC number in RH (both optional)
PNT -- symbol table pointer, if required
RES Code is written, RELOC bit is set to final value;
Formal fixup list (FORMFX) has been updated, if necessary.
SID All Ac's are saved except TEMP and LPSA.
;
BIT2DATA (EMITTER)
INDIR __ 20 ;THE INDIRECT BIT!!
;PNTROP __ 200 ;THIS OPERATION WILL DO POINTER INDEXING
; (PURELY LOCAL BIT, BUT DON'T SEND IT IN)
IMMED __ 1000 ;THE IMMEDIATE BIT (FOR SOME THINGS).
^XCALLQ:
SKIPE NOEMIT
POPJ P,
PUSH P,C ;LITTLE ROUTINE
HRL C,PCNT ;FOR CALLING LIBRARY ROUTINES.
EXCH C,(A) ;FIXUP INTO LIBRARY TABLE.
EMIT (<PUSHJ RP,NOUSAC!USADDR>)
POP P,C
POPJ P,
COMMENT EMITER Routine
^EMITER:
SKIPE NOEMIT ; GET OUT IF NO CODE IS TO BE EMITTED (I.E.
POPJ P, ; EXPR!TYPE)
PUSH P,A ;SAVE THOSE THINGS WHICH MIGHT CHANGE
PUSH P,C
PUSH P,D
PUSH P,TBITS
PUSH P,SBITS
TRZ A,PNTROP ;ASSUME NO POINTER OP
;;# # DCS 3-25-72 Eliminate bad array address problem
;;# # When [0,0,0]-word of array (location known, no fixup) falls
;;# # on reladr 0 of .REL file, CODOUT will mistake the 0 addr field
;;# # for end of fixup chain, will inhibit RELOC -- want RELOC in this
;;# # case. A bad fix, should be more generally solved.
TLO FF,RELOC!FFTMP1 ;AND RELOC (FFTMP1 FOR CODOUT 0-TEST)
;;# #
TRNE A,USADDR ;ADDR IN C(LH)?
JRST EAC ;YES, BYPASS SEMANTICS TESTING
TLZ FF,RELOC ;NOW ASSUME NO RELOCATION
HRRZS C ;CLEAR DISPLACEMENT FLD -- C(LH)
TRNE A,NOADDR ;IS THERE AN ADDRESS FLD AT ALL?
JRST EAC ;NO, FINISH UP
TRNE A,JSFIX
JRST EVAR ;GO DO A FIXUP
; NOW GET SEMANTICS AND DISPATCH TO CORRECT ROUTINE TO OUTPUT INSTR
MOVE SBITS,$SBITS(PNT)
MOVE TBITS,$TBITS(PNT)
;; #JR# BY JRL 10-17-72 A STRING ITEM IS NOT A STRING
TRNE TBITS,ITEM!ITMVAR
TRZ TBITS,STRING!DBLPRC ;FORGET ABOUT STRING TYPE FOR ITEMS
;; #JR#
NOSBS:
NOREC <
TRNN TBITS,PNTVAR ;IF PNTVAR OR INDXED OR
>;NOREC
TLNE SBITS,INDXED ; REFERENCE FORMAL,
TRO A,PNTROP ;INDICATE A POINTER OPERATION
TLNE TBITS,REFRNC
TRO A,PNTROP
TRNE A,ADDR ;IF ADDR and PNTROP, TURN OFF BOTH
TRZE A,PNTROP ;(THE IMMEDIATENESS
TRZ A,ADDR ; OF ADDR CANCELS THE INDIRECTNESS OF PNTROP
TLNE TBITS,SBSCRP ;ELIMINATE FXTWO IF
TRZ A,FXTWO ; ARRAY NAME
;;#FP# 1-10-72 DCS (1-2)
TLNE SBITS,INAC ;IN ACCUMULATOR?
JRST EINAC
;;#FP#
TLNE TBITS,FORMAL ;FORMAL PARAMETER (ACTUAL)?
JRST EFORM ;
TRNE A,PNTROP ;INDIRECTNESS DESIRED?
JRST EPNT
;;#FP# 1-10-72 DCS (2-2)
TLNE SBITS,PTRAC ;IN ACCUMULATOR? (WAS INAC TOO)
JRST EINAC
;;#FP#
TRNE A,ADDR ;SHOULD WE CONSIDER CONSTANT IMMED?
JRST EVAR ;NO
TLNE TBITS,CNST ;NUMERIC CONSTANT?
TRNE TBITS,STRING ;
JRST EVAR ; NO
ECONST: TRNN TBITS,DBLPRC ;CANT OPTIMIZE LONG PRECISION
SKIPE OPDUN ;NEVER OPTIMIZE USER INLINE CODE
JRST EVAR ; BUT REFER TO MEMORY
MOVE TEMP,$VAL(PNT) ;GET VALUE
TRNN A,IMMOVE ;IMMEDIATE MOVE REQUESTED?
JRST OPCON1 ; NO, TEST LH0
HRLI A,(<MOVE >) ;ASSUME MOVEI
TLC TEMP,-1 ;TEST LEFT HALF -1
TLCN TEMP,-1 ;IS IT?
JRST [HRL C,TEMP ;YES, SET UP
HRLI A,(<HRROI>) ; INSTR
JRST EAC] ;AND EMIT IT
TRNE TEMP,-1 ;RIGHT HALF ZERO?
JRST OPCON1 ; NO
MOVSS TEMP ;YES, SWAP HALVES
TLO A,4000 ; AND TURN ON MOVSI BIT
OPCON1: TLNE TEMP,-1 ;LEFT HALF ZERO?
JRST EVAR ;NO
HRL C,TEMP
LDB TEMP,[POINT 9,A,8] ;GET OP-CODE
SUBI TEMP,200 ;ONLY OPCODES IN RANGE <MOVE> (200)
JUMPL TEMP,EVAR ; TO <OR> (434) WILL
CAILE TEMP,234 ; BE CONSIDERED
JRST EVAR
PUSH P,USER
IDIVI TEMP,=36 ;WORD # TO TEMP, BIT # TO USER
MOVE TEMP,OPBTS(TEMP);SOME BITS
TABCONDATA (OPCODE BITS TABLE FOR EMITER OPTIMIZER)
OPBTS: 421042004000 ;BIT ON IF
000000104000 ;CORRESPONDING OPCODE
776000000000 ;CAN BE IMMEDIATE
; OLD WORD OBPTS+3 ;REPLACED (6-27-73)
; 001040000000
;; #KAB INCORRECT AND MISSING OBPTS ENTRIES
000000004200
401040000000
;; #KAB#
ENDDATA
LSH TEMP,(USER) ;THE RIGHT ONE
POP P,USER
JUMPGE TEMP,EVAR ;CAN'T OPTIMIZE, CODE WRONG
CAML A,[CAM] ;THE COMPARES ARE MADE
CAML A,[JUMP] ; IMMEDIATE BY TURNING OFF
TLOA A,IMMED ; THE 10000 BIT, ALL OTHERS
TLZ A,10000 ; BY TURNING ON THE 1000 BIT
JRST EAC ;PUT OUT OPTIMIZED INSTR
EPNT: HRRE TEMP,$VAL(PNT) ;GET DISPLACEMENT IF ANY
SUBI TEMP,1 ;ASSUME STRING AND FXTWO
;;#UE# (3 OF 3) INDEXED STRING ARRAY TEMPS ARE LOSERS
TLNE TBITS,SBSCRP ;IF AN ARRAY
AOJA TEMP,EPNT.1 ;JUST REVERSE ASSUMPTION QUAM CELERIME
;;#UE# ^
TRNN TBITS,STRING
ADDI TEMP,1 ;WAS NOT STRING
TRZE A,FXTWO
ADDI TEMP,1 ;WAS FXTWO
EPNT.1: HRL C,TEMP ;GET TO DISPLACEMENT PLACE
TLNE SBITS,PTRAC ;POINTER IN AC?
JRST EACX ; YES
TLNE C,-1 ;MAKE INDIRECT
ERR <DRYROT AT EPNT>,1 ;UNLESS WE WANTED A DISPLACEMENT
TRO A,INDRCT ;MAKE IT INDIRECT
JRST EVAR ;GO DO FIXUPS
EACX: HRL D,$ACNO(PNT) ;USE AC AS INDEX
TLNE TBITS,OWN ;IF ARRAY NAME COMES INTO IT,
;;# # DCS 3-25-72 Bad array address problem.
TLC FF,RELOC!FFTMP1;RELOCATABLE, SHOUDN'T 0-TEST IN CODOUT
;;# #
TRO A,USX ;DENOTE THAT IT SHLD BE DONE
JRST CHKIMM
EINAC: HRL C,$ACNO(PNT) ;INAC, GET ACNO AS DISPL.
TRNE TBITS,DBLPRC ;LONG
TRNN A,FXTWO ;AND FXTWO
JRST CHKIMM ; SEE IF ADDR IS ON
ADD C,[1,,0] ;MEANS AC+1
JRST CHKIMM
EFORM: TRO A,USX ;WILL NEED TO USE A STACK AS INDEX
HRRZ TEMP,$ADR(PNT) ;GET DISPL FROM STACK TOP
TDNN TBITS,[SBSCRP!REFRNC,,PROCED!ITEM!ITMVAR] ;THESE ARE NOT VALUE LONGS
TRNN TBITS,DBLPRC ;LONG?
JRST .+3 ;NO
TRZE A,FXTWO
SUBI TEMP,1 ;FXTWO ON LONG FORMAL MOVES CLOSER TO STACK TOP
TLNE TBITS,REFRNC ;REFERENCE PARAM?
JRST REFPRM ; YES
VALPRM: TRNN TBITS,STRING ;STRING
JRST REFPRM ;NO
SKIPN SIMPSW
TRNN SBITS,DLFLDM ;IF SIMPLE OR DL 0 THEN DO IT THE OOLD WAY
JRST USERSP
LDB LPSA,[LEVPOINT(SBITS)]; PICK UP LEVEL
HLL D,DISTAB(LPSA) ;PICK UP REGISTER
TLNN D,17
;;#MN# 7-13-73 THE FRIDAY 13 ACCESS KLUGE
JRST [
PUSH P,TEMP
HLRZ TEMP,LSDRLV ;MAYBE THE THING IS STILL AROUND
CAIE TEMP,(LPSA)
ERR <DRYROT AT EFORM FOR STRING> ;BETTER NOT BE 0
HLL D,LSDRNM ;GET THE OLD THING
POP P,TEMP
JRST .+1]
;;# #
TRZE A,FXTWO ;IF SECONG WORD
SUBI TEMP,1 ;FIX IT
MOVN TEMP,TEMP
HRL C,TEMP ;USE THIS DISPL
JRST CHKIMM ;GO CHECK
REFPRM: TLNN TBITS,SBSCRP ;IF SUBSCRIPTED AND
JRST .+3 ; REFERENCE,
TLNE TBITS,REFRNC ;
TRZ A,PNTROP ;DO NOT GO INDIRECT.
TRZE A,PNTROP ;WANT TO GET VALUE?
TRO A,INDRCT ; YES, GO INDIRECT, FIND ON RP STACK
LDB LPSA,[LEVPOINT(SBITS)];PICK UP DISPLY LEVEL
CAIE LPSA,0 ;IF HAVE A DISPLAY
JRST USEDRF ;USE IT
MOVE LPSA,TPROC ;PICK UP PROC ID
HRRZ LPSA,$SBITS(LPSA);PICK UP RH OF SBITS FOR PROC
ADDI LPSA,1 ;WANT LEVEL OF FORMLS
XOR LPSA,SBITS ;ALL THIS IS A FANCY TEST TO SEE IF THIS PROC'S
TRNE LPSA,LLFLDM ;IS IT THE SAME
ERR <INACCESSABLE FORMAL> ;NO
SKIPN SIMPSW ;BETTER BE SIMPLE PROC
ERR <DRYROT AT EPNT -- SIMPLE?> ;YOU FUCKED UP
USERP: HRLI D,RP ;MARK THIS STACK
ADD TEMP,ADEPTH ;TOTAL ARITH STACK DEPTH
JRST MAKFRM ;GO CREATE FORMAL REF INSTR
USERSP: HRLI D,RSP
ADD TEMP,SDEPTH
TRZE A,FXTWO ;SECOND WORD?
SUBI TEMP,1 ;YES, DON'T GO SO FAR
MAKFRM: MOVNS TEMP ;NEGATIVE STACK DISPLACEMENT
HRL C,TEMP ;USE THIS DISPLACEMENT
;;#KH# RHT (11-21-72) DELETED LARGE HUNKOF LEFT OVER STUFF FROM FORMFX
JRST CHKIMM ;FINISH OUT
USEDRF: HRL D,DISTAB(LPSA) ;PICK UP DISPLAY REGISTER
TLNN D,-1 ;WAS IT LOADED
;;#MN# FRIDAY 13 JULY
PUSHJ P,[DRKLUG:
PUSH P,TEMP
HRRZ TEMP,LSDRLV
CAIE TEMP,(LPSA) ;OLD LEVEL THERE???
ERR <DRYROT AT EFORM>,1;NO
POP P,TEMP
HRL D,LSDRNM
POPJ P, ]
;;# #
MOVN TEMP,TEMP ;NEGATE DISPL
SUBI TEMP,1 ;SINCE RF IS ONE MORE AWAY
HRL C,TEMP ;USE IT
JRST CHKIMM ;GO FINISH UP
EVAR:
TLO FF,RELOC ;NOW ASSUME RELOC AGAIN
;;#VM# ! JFR 10-30-75 PARANOIA THAT PROCEDURES COULD SLIP THROUGH
TRNN TBITS,PROCED
TRNE A,JSFIX ;IF JUST WANT A FIXUP
JRST USECR ;THEN THATS ALL YOU GET
TLNE SBITS,CORTMP ;IS IT A CORE TEMP
JRST [ ;YES
SKIPN RECSW ;IF NOT RECURSIVE PROC THEN
JRST USECR ;USE A CORE LOCN -- NO DR NEEDED
MOVE LPSA,CDLEV ;USE THIS LEVEL
JRST USED.1 ;NO LDB ALLOWED
]
TRNE SBITS,DLFLDM ;STACK VAR?
JRST USEDR ;YES
USECR:
HRL C,$ADR(PNT) ;ADDR OR LAST FIXUP
DCDFX: TRNN A,JSFIX
TRNE TBITS,FORWRD!INPROG ;MUST FIXUP IF EITHER IS ON
JRST DOFIX
TLNN SBITS,FIXARR ;DON'T FIXUP IF FIXARR ON
TRNE TBITS,PROCED!LABEL ;ELSE ONLY IF NEITHER OF THESE
JRST DONTFX
REC <
TRNE TBITS,PNTVAR ;CHECK FOR CLASS ID
TRNN TBITS,SHORT ; IE SHORT PNTVAR
JRST DOFIX
JRST DONTFX ;CLASS ID NOT FIXED UP
>;REC
NOREC <
JRST DOFIX ;HERE DO IT
>;NOREC
USEDR: LDB LPSA,[LEVPOINT<SBITS>] ;GET DISPLAY LEVEL
USED.1: HRL D,DISTAB(LPSA) ;USE DISPLY REG
TRNE TBITS,STRING ;UNLESS STRING
JRST [
;#IO# RHT 7-17-72 ATTEMPT TO USE STR DR FOR A INDEXED TEMP
TLNE SBITS,INDXED ;DONT IF RESULT OF ARRAY CALC
JRST .+1 ;
;# #
TLNN TBITS,SBSCRP ;DONT FOR ARRAYS
HLL D,DISTAB(LPSA) ;CODED THIS WAY TO HANDLE USUAL CASE
JRST .+1]
TRNE A,USX ;BETTER NOT PLAN TO INDEX THIS
ERR <DRYROT AT EVAR>,1 ;NO
TLNN D,-1 ;WAS IT LOADER
;;#UV# JFR 8-16-75 WHAT A HACK.
PUSHJ P,DRKLUG ;FIX RACE CONDITION. GET (ACCESS)
;FOUND THE DISPLAY REG, BUT ACCOP USED THE REG SINCE
;ALL OTHERS WERE BUSY. HACK, HACK.
HRL C,$ADR(PNT) ;PICK UP DISPL
TRO A,USX ;USE THE MOTHER
JRST DCDFX ;GO THINK ABOUT FIXING UP
DOFIX: HRRZ TEMP,PCNT ;READY TO DO FIXUP CHAINING
TRZE A,FXTWO ;USE SECOND FIXUP ADDR
JRST [HLL C,$ADR(PNT)
HRLM TEMP,$ADR(PNT) ;YES, MATTER OF FACT
JRST CHKIMM]
HRRM TEMP,$ADR(PNT) ;FINISH FIXUP CHAINING
DONTFX:
TLNN SBITS,FIXARR
JRST CHKIMM
;;#YY# JFR 2-12-77 MAKE LOGIC CLEARER AND FXTWO OF LONG DO THE RIGHT THING
;; SUB C,[XWD 1,0] ;ASSUME STRING, NOT FXTWO
;; TRNE TBITS,STRING ;IF NOT STRING OR IF FXTWO,
;; TRZE A,FXTWO
;; ADD C,[XWD 1,0] ; NULLIFY ASSUMPTION
TRZE A,FXTWO
ADD C,[XWD 1,0] ;FXTWO, SO 2ND WD
TRNE TBITS,STRING
SUB C,[XWD 1,0] ;EXCEPT STRINGS HAVE ORIGIN AT -1
;;#YY# ^
CHKIMM:
TRNN A,ADDR ;DO WE WANT THIS POINTER RAW?
JRST EAC ; NO, FINISH UP
TLO A,IMMED ;THE ONLY WAY TO DO IT HERE IS TO
TRNE A,USCOND ; MAKE THE INSTR IMMEDIATE
HRLI A,(<CAI>) ; (CONDITIONAL MUST BE A CAM)
EAC: TRNE A,INDRCT ;INDIRECT BIT WANTED?
TLO A,INDIR
TRNN A,NOUSAC ;AC FLD PROHIBITED?
DPB D,[POINT 4,A,12] ;NO, PUT IT IN
TRNE A,NORLC ;RELOCATION PROHIBITED?
TLZ FF,RELOC ; YES, TAKE IT OUT
TRNE A,USCOND ;CONDITION BITS NEEDED TO FINISH OPCODE
DPB C,[POINT 3,A,8] ;YES, DO IT
TRNE A,USX ;D(LH) TO BE USED AS INDEX FLD?
TDO A,D ;YES (WIPES OUT A(RH))
HLR A,C ;GET DISPL (SO DOES THIS)
;;# # DCS 3-25-72 bad array address problem
MOVEI TEMP,CODOUT ;STANDARD CASE
TLNN FF,FFTMP1 ;IF THIS BIT GOT TURNED OFF, CODREL SHOULD
MOVEI TEMP,CODREL ; BE CALLED TO AVOID THE 0-TEST WHICH
PUSHJ P,(TEMP) ; WOULD INHIBIT RELOC -- PUT OUT THE CODE
;;# #
POP P,SBITS
POP P,TBITS
POP P,D
POP P,C
POP P,A
;;#MN# 7-13-73
SETZM LSDRLV ;REALLY ONLY NEED TO ZERO THIS
SETZM LSDRNM ;REALLY WILL DO THIS ANYHOW
;;# #
POPJ P, ;RESTORE AND RETURN
SUBTTL Generalized push and pop.
COMMENT Qstack Routines -- BPUSH, etc.
DSCR QSTACK ROUTINES
DES These are routines to provide generalized, expandable push-
down stacks (buffers? queues?) for use by algorithms which need
widely varying storage, accessed in simple ways. Such structures
are called QSTACKS, and are built out of Semblks as follows --
WORD1 -- ptr to PREV,,ptr to NEXT
WORDS 2-11 -- up to 10 words of "stack" data
A stack is identified by its QPDP, or Qstack Descriptor, which is --
ptr TOP,,ptr Semblk containing TOP
Most Qstack operations reference the address where this QPDP (there
should be one QPDP which always refers to the TOP) is stored. Others
may also be used in conjunction with Qstack operations
Qstack operations are provided to PUSH data on, POP data off (these
allocate and release Semblks, if necessary, and change the TOP QPDP),
access data non-destructively in forward and reverse directions, and
to clear a given Qstack.
DSCR BPUSH
CAL PUSHJ via QPUSH macro
PAR LPSA ptr to QPDP for Qstack
A is data to be pushed
RES QPDP is updated, A is stored in Qstack, new Semblk if necessary
DES if QPDP is 0, an initial Semblk is created, QPDP constructed.
SID only TEMP is changed
SEE QPUSH
^BPUSH: PUSH P,A ;SAVE IT.
SKIPN TEMP,(LPSA) ;THE CURRENT POINTER
JRST NEWONE ;NONE YET, GUYS.
HLRZ A,TEMP
CAIL A,BLKLEN-1(TEMP) ;GONE OVER BLOCK BOUNDARY?
JRST NOTHER ;YES
PUSH1: PUSH A,(P) ;SEE !!!
HRLM A,(LPSA) ;CURRENT POINTER UPDATED.
POP P,A ;RESTORE
POPJ P, ;DONE
NEWONE: PUSH P,LPSA
GETBLK ;GET A NEW BLOCK.
SETZM (LPSA)
MOVE TEMP,LPSA ;POINTER TO NEW BLOCK.
POP P,LPSA
MORBLK: HRRM TEMP,(LPSA) ;UPDATE PDP POINTER.
HRRZ A,TEMP
JRST PUSH1 ;FINISH OUT.
NOTHER: PUSH P,LPSA ;SAVE IT
GETBLK
MOVE TEMP,LPSA ;POINTER TO NEW ONE.
POP P,LPSA
HRRZ A,(LPSA) ;PDP POINTER.
HRLZM A,(TEMP) ;SAVE LINKS IN NEW BLOCK.
HRRM TEMP,(A) ;AND IN PDP
JRST MORBLK
DSCR BPOP
CAL PUSHJ via QPOP macro
PAR LPSA ptr to QPDP
RES A _ data from TOP, QPDP is updated
DES Semblks are released as they are emptied
SID only TEMP, A are changed
ERR if there is no QPDP, or if no more data, error
SEE QPOP
^BPOP: SKIPN TEMP,(LPSA) ;PDP POINTER
ERR <DRYROT -- BPOP>
HLRZ A,TEMP
POPMOR: SUBI A,1 ;THIS IS A POP
CAIGE A,(TEMP) ;GONE BELOW THIS BLOCK?
JRST POPBAK ;YES ALAS
HRLM A,(LPSA) ;UPDATE PDP
MOVE A,1(A) ;THIS IS THE RESULT.
POPJ P,
POPBAK: PUSH P,TEMP
HLRZ TEMP,(TEMP) ;BACKWARD POINTER.
PUSH P,TEMP
FREBLK <-1(P)> ;DELETE THE BLOCK.
POP P,TEMP
POP P,(P) ;INGNORE THIS.
SKIPN TEMP ;IS IT THERE?
ERR <DRYROT -- BPOP>
HLLZS (TEMP) ;ZERO FORWARD POINTER
MOVEM TEMP,(LPSA) ;UPDATE PDP
MOVEI A,BLKLEN-1(TEMP) ;NEW MAX.
JRST POPMOR ;FINISH OUT.
DSCR QTAK
CAL PUSHJ, via QTAKE macro
PAR B is QPDP for data word preceding one desired
LPSA ptr QPDP for this QSTACK
RES if there is more data (check via LPSA ptr):
B is updated as if it were a BPUSH QPDP
A receives value of TOP
BTAK skips
if there is no more data:
nothing is changed
BTAK does not skip
SID only A,B, TEMP changed
SEE QTAKE macro
^QTAK: CAMN B,(LPSA) ;OVERFLOW?
POPJ P, ;YUP
HLRZ TEMP,B
CAIL TEMP,BLKLEN-1(B) ;OVERFLOW OF OTHER TYPE?
JRST NEXTBL ;YES
TAKMOR: MOVE A,1(TEMP)
HRLI B,1(TEMP)
AOS (P)
POPJ P,
NEXTBL: HRRZ B,(B) ;GO FORWARD
HRRZ TEMP,B ;NOTE THAT THE BLOCKS ARE
JRST TAKMOR ;NOT DELETED !!!!!!
DSCR BBACK
CAL PUSHJ via QBACK macro
PAR B contains QPDP
RES B is "popped"
A receives data from TOP word
if there was data left, skip-returns -- else no-skip
SID only A, TEMP, B changed
SEE QBACK
^^BBACK: HLRZ A,B ;ptr to TOP, ACCORDING TO B'S QPDP
BTMOR: SUBI A,1 ;TRY THE "POP"
CAIGE A,(B) ;WAS THERE DATA LEFT HERE?
JRST BTBAK ;NO, BACK UP
HRLM A,B ;UPDATE B'S QPDP
MOVE A,1(A) ;FETCH "TOP" ELEMENT
AOS (P) ;SUCCESS UNLESS SOSED BY BTBAK
QPOPJ: POPJ P, ;DONE
BTBAK: HLRZ B,(B) ;BACK UP
JUMPE B,QPOPJ ; NO MORE DATA
MOVEI A,BLKLEN-1(B) ;RESET LH PTR
JRST BTMOR ;FINISH UP
DSCR BFLUSH
CAL PUSHJ, via QFLUSH macro
PAR LPSA ptr to QPDP
RES all Semblks cleared, QPDP zeroed
SID A, B, TEMP changed
SEE QFLUSH
^^BFLUSH: SKIPN A,(LPSA)
POPJ P, ;NO STACK
FLSHLP: HLRZ B,(A) ;GET NEXT PTR
FREBLK (A) ;RELEASE TOP SEMBLK
MOVE A,B
JUMPN A,FLSHLP ;MAKE NEXT ONE BACK TOP ONE
SETZM (LPSA) ;ALL DONE
POPJ P,
DSCR BBEG
CAL PUSHJ, via QBEGIN macro
PAR B is QPDP
RES B is QPDP which, when BTAKEd, returns first element in Qstack
B is 0 if no Qstack exists
SID only B, TEMP changed
SEE QBEGIN
^^BBEG: SKIPN B,(LPSA) ;IS THERE A STACK?
POPJ P, ; NO
LOPPP: HRLS B ;MAKE INIT QPDP FOR THIS SEMBLK
HLRZ TEMP,(B) ;GET BACK PTR
JUMPE TEMP,CPOPJ ;WHEN HAVE REACHED FIRST SEMBLK, QUIT
MOVE B,TEMP ;TRY AGAIN
JRST LOPPP
COMMENT PWR2
DSCR PWR2
DES Tests number in register B for being a power of 2.
if so, it skip-returns (********) and C
has a small integer representing the power.
SID AC'S: uses TEMP
;
^PWR2: JUMPLE B,CPOPJ ;ROUTINE TO TEST B FOR A POWER OF TWO.
MOVN TEMP,B ;TWO'S COMPLEMENT.
AND TEMP,B ;AND THE AND
TLNN B,777000 ;TOO BIG ?
CAME TEMP,B ;THE MAGIC TEST FOR POWER OF TWO.
POPJ P, ;NO DICE.
FSC B,233 ;NOW THE NORMALIZE.
ASHC B,-=44 ;NOW CORRECTLY IN C. (LEFT HALF)
SUB C,[XWD 201,400000]
AOS (P)
POPJ P,
SUBTTL Generator Output Routines.
COMMENT GBOUT Description, Loader Block Format Description
DSCR GBOUT -- write a block of binary output
DES
One of the specialized output routines has produced
a loader block, ready for output. These
routines are:
CODOUT -- prepares a code block. Each call
puts a word of code into a buffer and sets relocation
appropriately.
FBOUT -- prepares a fixup block. Each call puts a fixup word into
a buffer.
SOUT -- for outputting symbols. Each call puts a symbol
name (in RADIX50) and an address into a buffer.
Other parts of the generators also call GBOUT for special functions
(entry block, prog name block, etc). The routines
call GBOUT when their buffers are full or when they
wish to force out all of a given block.
Each block outputted by GBOUT has the same general format:
WD1: BLOCK TYPE,,COUNT
0 LEQ COUNT (WDn-WD3+1) LEQ 18
WD2: relocation bits
18 2-bit bytes (left-justified) corresponding
to the 18 (maximum) data words in the block.
The first bit of each is on if the left
half is to be relocated. The second bit
of each corresponds to the right half
of its data word.
WD3: first data word
.
.
.
WDn: last data word 2 LEQ n LEQ 20
The Binary file is opened and initialized in the command
scanner (outer block of SAIL). The FF bit BINARY
is on if a binary output is desired (if the file is open).
PAR B -- SIZE,,address of loader block
SIZE is size of ENTIRE block (2 + WD1's count)
It is zero if WD1's COUNT is to be believed.
RES The block is written if SIZE is GEQ 3
SID All ACS are preserved
;
COMMENT Control Variables for Loader Block Output
ZERODATA (REL-FILE OUTPUT VARIABLES)
;CODPNT -- bp for relocation bits in BINTAB CODE block
; see GBOUT for details about relocation bits -- initted to --
?CODPNT: POINT 2,BINTAB+1
;FRSTSW -- off until first word of code goes out -- used to
; trigger output of program name block, initial code, etc.
; in CODOUT -- set on in CODOUt
?FRSTSW: 0
;FXPNT -- reloc bits bp for FXTAB FIXUP block -- see FBOUT, GBOUT
?FXPNT: POINT 2,FXTAB+1
;LSTRAD, LSTRLC, LSTWRD -- last radix50 word output, last code
; word output, last relocation bits output -- used by Boolean
; and ALLOT code, for repeating some of it
^^LSTRAD: 0
^^LSTRLC: 0
^^LSTWRD: 0
;OUTADR -- bp set up by GBOUT for fetching words from LODBLKs
; for transfer to output buffer
?OUTADR: 0
;RAD5. -- RADIX50 creates a value corresponding to a symbol comprising
; the first 5 characters of the identifier, followed by ".", in
; addition to each value it creates. It is saved here, used sometimes.
^^RAD5.: 0
^^RAD5$: 0 ;SIMILAR, BUT WITH A $
^^RAD5%: 0 ;GUESS WHAT
;SMPNT -- reloc bits pb for SMTAB SYMBOLS block -- see SCOUT, GBOUT
?SMPNT: 0
DATA (REL-FILE OUTPUT VARIABLES)
;SALIB -- used to place main SAIL library request in LBTAB output
; loader block -- see DONES, PRGOUT
;SALIH -- re-entrant version of library
^SALIB: LIBLOW ;[clh] STRING CONSTANT, LIBLEN LONG
;;#HX# 6-24-72 DCS PARAMETERIZE LIBRARY NAMES
REN <
^SALIBH:LIBHI ;[clh]
;;#HX#
>;REN
BAIL<
^BAIREL: BAILOD ;[clh] STRING CONSTANT, BALENG LONG
^BAIPD: BAIPDS ;[clh] STRING CONSTANT
>;BAIL
COMMENT Loader Output Blocks-- Entry, Program Name, Initial Stuff
DATA (LOADER OUTPUT BLOCKS)
COMMENT
Here are the loader output blocks. They are formatted as described
in SAILON ;;.; by Bill Weiher. The general routine GBOUT handles
the actual output of these (filled) blocks to the .REL file. For
several of the block types, special routines exist below (CODOUT,
FBOUT, etc.) to place individual words (and their relocation) into
the blocks, and to call GBOUT when a block is full
COMMENT
ENTTAB -- ENTRY block -- names included in SAIL ENTRY statements.
This must be the first block out (due both to syntax and
necessity. It allows the .REL file to be used as part
of a library.
LODBLK (ENTRY,4,ENTTAB,,=18)
COMMENT
PROGNAM -- PROGRAM NAME BLOCK -- output of this block is delayed until
first word of code goes out, to give user longest possible time
to come up with a program name. Must go out before code to name
outer block symbols and labels and stuff.
;;%CL% JFR 7-22-75 IDENTIFY OURSELVES TO LINK-10
LODBLK (PROGNAM,6,BEGNAM,BEGCNT,2)
RELOC .-2
^^PRGTTL: RADIX50 0,M ;DEFAULT NAME, IF NO OTHER COMES
XWD 7,0 ;7 means SAIL, bits 0-5 tell hardware assumptions
;;%CL% ^
COMMENT
HBLK -- High Segment Block -- Denotes Re-entrant Output
REN <
LODBLK (HIGH,3,HBLK,HBLK2,1,,<XWD 200000,0>)
RELOC .-1
XWD 400000,400000 ;TWOSEG
>;REN
COMMENT
BEGOUT -- STANDARD INITIAL CODE SEQUENCE
This code is always put out, but is only executed (and fixups
are only correct) for Main Programs. Sample fixed-up code is
included in the comments
LODBLK (CODE,1,BEGOUT,BEGCT2,10,,<XWD 200000,0>)
RELOC .-10
^^BEGPC:0 ;PC ALWAYS 0 OR 400000
SKIPA ;NOT STARTED IN RPG
SETOM ;RPGSW
JSR ;SAILOR
;;%AL% THE HRLOI IS NOW DONE BY SAILOR
;; HRLOI RF,1 ;FOR FIRST LINK
PUSH P,RF
PUSH P, ;[PDA,,0]
PUSH P,SP
HRRI RF,-2(P); SET F
COMMENT Code, Boolean Code, Fixups, Links
COMMENT
BINTAB -- MAIN CODE BLOCK
All generated instructions are output via CODOUT-GBOUT
to this block. See CODOUT for details
LODBLK (CODE,1,BINTAB,,=18)
COMMENT
BOLOUT -- SPECIAL BOOLEAN CODE BLOCK
Conditionals are output once when a condition is seen, and
again (with fixups and compare op codes correct) when the
entire Boolean expression has been parsed and analyzed.
See BOOLEAN for details.
LODBLK (CODE,1,BOLOUT,,0,,<XWD 200000,0>)
^^BRELC_.-1 ;TO ACCESS RELOCATION BITS
^^BPCNT: 0 ;PROGRAM COUNTER -- SAME AS WHEN INSTRS FIRST OUT
^^BWRD1: 0 ;COMPARE, SKIP, OR CONDITIONAL JUMP
^^BWRD2: 0 ;UNCONDITIONAL JUMP IF BWRD1 WAS A COMPARE OR SKIP
^^BWRD3: 0
COMMENT
FXTAB -- FIXUPS
Each word contains in its right half the address or stack
displacement (reloc bits adj. accordingly) of a variable
or instruction. The left half contains the address
(relative to 0, of course) of the last instruction or data
which requires this address field. This location, in turn,
was compiled to refer to the next previous use of the variable
or whatever... in other words, a fixup chain (terminates in 0).
The LOADER uses these fixups to handle forward references to
things. See FBOUT for details
LODBLK (FIXUPS,10,FXTAB,,=18,-1)
COMMENT
SMTAB -- SYMBOLS
All local and internal symbols, and global requests, are output
through this block. See SCOUT and friends for details.
LODBLK (SYMBOLS,2,SMTAB,,=18,<XWD 42104,210421>)
;(RELOCATE EVERY OTHER WORD -- GENERALLY)
COMMENT
SLNKBK -- LINK BLOCKS
The string link, space link, and other links are output
through this block. These links provide inter-RELfile
communication (best example is link that chains all string
variables together, so that STRNGC can get at them. See
LNKOUT for details.
LODBLK (LINK,12,SLNKBK,SDSCRP,2,,<XWD 40000,0>)
RELOC .-2
^^LNKNM: 1 ;USUALLY STRING LINK, BY CONVENTION #1
;SPACE LINK IS #2
;SET LINK IS #3
;STRNGC ROUTINE NAMES LINK IS #4
; THESE ARE SAIL CONVENTIONS ONLY
^^SLNKWD: 0 ;ADDRESS OF ELEMENT OF CHAIN
COMMENT Space Allocation Block
SBCTBL -- SPACE ALLOCATION BLOCK
In this block is collected all REQUIRE specifications
(except LOAD!MODULES, LIBRARIES, SOURCE!FILES) and
space limits (string space, system pdl, new items, etc.)
It is output as a code block. Also output is a link
block tying this space block to all the others loaded
together. The SAILOR (initialization) routine uses this
information to provide an environment pleasing to the user.
See DONES and the REQUIRE code for more details. Also GOGOL
(%ALLOC) for block format explanations
;;%BR% RHT ALLOW COMVER THING FOR EVERYONE (BUT KEEP EXPO FOR NOW)
^^SPCSIZ__=17 ;$SPREQ+1 ;IF EVER MAKE 18 OR MORE, MUST CHANGE SOME THINGS
;;^^SPCSIZ__=14 ;BAD OLD VALUE *****
;;%BR% ^
^^SPCTBL:XWD 1,SPCSIZ ;CODE BLOCK, AT LEAST SPCSIZ LONG
BYTE (2) 1,0,0,0,0,1,0,0,0,0,0,0,1,1,0,1
;PC WORD,MESLNK,TINIT,PINIT,OBPDA(RELOC)
^SPCPC: 0 ;PC LOCATION
0 ;LINK BLOCK PROVIDES CHAIN THROUGH THIS LOC
;; %AG% HAVE ITEMNO KEEP BOTH MIN AND MAX
^ITEMNO:0 ;MIN,,MAX ITEM NUMBER DECLARED THIS COMPILATION
^NWITM: 0 ;REQUIRE n NEW!ITEMS PUTS n HERE
;; %AG% ! HAVE GITEMNO CONTAIN LEAPIS FLAG
^GITEMNO:0 ;XWD LEAPIS,MAX (MIN?) GLOBAL ITEM NUMBER DECLARED
^MESLNK:0 ;POINTER TO MESSAGE PROCEDURE LIST PUT HERE
^PNAMNO:0 ;REQUIRE n PNAMES PUTS n HERE
^VERNO: 0 ;REQUIRE n VERSION PUTS n HERE
^SEGNAM:0 ;REQUIRE "name" SEGMENT!NAME PUTS "name" HERE IN SIXBIT
^SEGDEV:0 ;REQUIRE "dev:file[p,pn]" SEGMENT!FILE PUTS
^SEGFIL:0 ; dev, file, ppn IN THESE LOCS IN SIXBIT
^SEGPPN:0 ;(LOW BIT OF DEV IS SEGMENT PROTECT BIT, NOT USED NOW)
^TINIT: 0 ;INITIALIZATION BLOCK ADDRESS FOR DECLARED ITEM TYPES
^PINIT: 0 ;INIT. BLOCK FOR PNAMES(DECLARED ITEMS)
;;%BR%
^^COMVER: 0 ;NICE THING, BUT SUAI
;;%BV% !
^^OBPDA:0 ;OUTER BLOCK PDA
0 ;SPARE
;;%BR% ^
BLOCK 50 ;ROOM FOR MORE REQUESTS
^SPCEND__.-1
COMMENT Request Blocks -- RELfile, Libraries
COMMENT
PRGTAB -- RELFILE REQUEST BLOCK
REQUIRE "...." LOAD!MODULE generates one of these. The LOADER
loads all requested .REL files after loading all the explicit
stuff. See REQUIRE code for details
;; #KS# ADD LOADVR SWITCH
IFN (LOADVR-=54), <
LODBLK (RELREQ,15,PRGTAB,,=18)
>
IFE (LOADVR-=54), <
LODBLK (RELREQ,16,PRGTAB,,=18)
>
;; #KS#
COMMENT
LBTAB -- LIBRARY REQUEST BLOCK
REQUIRE "...." LIBRARY generates one of these (SAIL main programs
automatically request SYS:LIBSAI.REL). The LOADER searches these
libraries, if necessary, after searching all the others except the
automatic F4 search.
;; #KS# LOADVR SWITCH
IFN (LOADVR-=54), <
LODBLK (LIBREQ,16,LBTAB,,=18)
>
IFE (LOADVR-=54), <
LODBLK (LIBREQ,17,LBTAB,,=18)
>
;; #KS#
COMMENT Ending Code, Symbols -- END Block
STAROT ETC. -- ENDING STUFF.
These include some constant ending code, some extra standard
symbols, the starting address block, if there is one, and so on.
It's too messy to use the LODBLK macro on, so here it is in
all its glory--
EBLEN__. ;COLLECT LENGTH.
;If this is a Main Program, a starting address block is issued
; (via the GBOUT descriptor EBDSC); else EBDSC1 is used to issue
; all but the starting address block. Starting address is always
; relative 0 (addr of the BEGOUT code--see above)
?STAROT: XWD 7,1 ;STARTING ADDR BLOCK -- 1 DATA WORD
XWD 200000,0 ;RELOCATE ADDRESS (RH)
^STRDDR:0 ;STARTING ADDRESS ALWAYS REL 0
; If Main Program, global requests must be issued to fill in
; the RPGSW and SAILOR blanks in the BEGOUT block (above)
XWD 2,4 ;SYMBOL BLOCK
XWD 42104,210421 ;EVERY OTHER WORD.
^CONSYM:RADIX50 60,SAILOR;JSR REQUEST.
2 ;JSR IS IN LOC 2
RADIX50 60,RPGSW;FOR SETOM RPGSW BUSINESS
1 ;SETOM IS IN 1
; This part is always issued -- standard symbol names, end block
NOSTAR: XWD 2,STRCT-NOSTAR-2;SYMBOLS
XWD 40000,0;RELOCATE ONLY S.
RADIX50 10,S. ;FIRST EXECUTABLE LOC IN PROG
0 ;ALWAYS 0
RADIX50 10,P ;SYSTEM PDP ADDR
RP ;USUALLY 17
RADIX50 10,SP ;STRING PDP ADDR
RSP ;USUALLY 16
RADIX50 10,ARERR;UUO FOR ARRAY INDEX OV/UNDERFLOW
ARERR ;THE UUO OPCODE
RADIX50 10,FLOAT;UUO FOR INTEGER to REAL
FLOAT
RADIX50 10,FIX ;UUO FOR REAL to INTEGER
FIX
RADIX50 10,SNGL ;UUO FOR LONG REAL to REAL
SNGL
STRCT: ;END OF EXTRA SYMBOLS
; END BLOCK
NOREN <
XWD 5,1 ;END BLOCK.
XWD 200000,0 ;RELOCATE PROGRAM BREAK WORD
^^PRGBRK: 0 ;PROGRAM BREAK-- FIRST NON-USED ADDR
>;NOREN
REN <
XWD 5,2 ;TWO PROGRAM BREAKS
XWD 240000,0 ;RELOCATE PROGRAM BREAK WORD
^^PRGBRK: 0 ;HIGH-SEG PROGRAM BREAK
0 ;LOW-SEG PROGRAM BREAK
>;REN
EBLEN__ .-EBLEN ;LENGTH OF ENTIRE OUTPUT RITUAL
^EBDSC: XWD EBLEN,STAROT ;IF MAIN PROGRAM
^EBDSC1:XWD EBLEN+STAROT-NOSTAR,NOSTAR ;IF NOT
ENDDATA
COMMENT RELINI -- Loader Block Initialization
DSCR RELINI
CAL PUSHJ FROM GENINI
DES SETS UP ALL REL-FILE OUTPUT STUFF BEFORE EACH COMPILATION
^^RELINI:
HLLZS BINTAB
HLLZS FXTAB
SETOM FXTAB+1 ;ALL RELOCATABLE
HLLZS SMTAB ;CLEARS OUTPUT BUFFER COUNTS
HLLZS PRGTAB ;PROGRAM AND LIBRARY REQUEST BLOCKS
HLLZS LBTAB
MOVE A,[XWD SPCPC,SPCPC+1] ;CLEAR SPACE ALLOCATION BLOCK
SETZM SPCPC
BLT A,SPCEND ;SIZE ALLOCATION BLOCK.
HRRI TEMP,SPCSIZ
HRRM TEMP,SPCTBL
POPJ P, ;RETURN TO GENINI
COMMENT GBOUT Routine
^GBOUT:
PUSH P,A ;SAVE A
PUSH P,B ;SAVE ADDRESS OF BUFFER
HLRZ A,B ;GET COUNT IF NONSTANDARD
TLO FF,IREGCT ;SET NON-STANDARD COUNT BIT
HRLI B,(<POINT 36,0>) ;FOR PICKING UP WORDS
MOVEM B,OUTADR ;SAVE TABLE ADDRESS
JUMPN A,GBOUTA ;NOT STANDARD (FROM TABLE) COUNT
HRRZ A,(B) ;GET COUNT FROM BLOCK
;;#TR# BE MORE HONEST ON COMPUTING THIS
; ADDI A,2 ; +2 FOR BLOCK TYPE & RELOC
ADDI A,=35 ; CNT _ CNT+1+FLOOR((A+17)/18)
IDIVI A,=18
HRRZ B,@OUTADR ;WORD CNT AGAIN
ADD A,B ; CORRECT VALUE (I HOPE)
TLZ FF,IREGCT ;RESET NON-STANDARD COUNT BIT
; OUTPUT ROUTINE
GBOUTA: TLNN FF,BINARY ;IS THERE A BINARY FILE?
JRST OUTDUN ;NO, DON'T WRITE
CAIGE A,3 ;IS THERE ANYTHING TO WRITE?
JRST OUTDUN ;NO, DON'T DO IT
NOTENX <
BQN: SOSLE BINCNT ;FULL?
JRST OKOUT ;NO
OUTPUT BIN,0 ;EMPTY BUFFER, ON TO NEXT
TSTERR BIN ;ERRORS?
ERR <OUTPUT ERROR ON BINARY FILE>
OKOUT: ILDB B,OUTADR ;BLOCK WORD
IDPB B,BINPNT
SOJG A,BQN ;WRITE THEM ALL
>;NOTENX
TENX <
PUSH P,C
MOVNI C,(A)
MOVE B,OUTADR
SKIPL A,BINJFN ;JUST IN CASE IT'S -1 (DUMMY)
JSYS SOUT
MOVEM B,OUTADR ;UPDATE OUTADR
POP P,C
>;TENX
OUTDUN: POP P,B ;GET BUFFER ADDR BACK
TLZN FF,IREGCT ;DON-'T CLEAR IF NON-STANDARD COUNT
HLLZS (B) ;CLEAR COUNT
POP P,A ;RESTORE A
POPJ P,
COMMENT CODOUT Routine -- Output Code or Data
DSCR CODOUT -- WRITE DATA (ALSO CODREL)
PAR WORD IN "A"
relocatable if RELOC in in "FF"
(if rh of A is zero, then never RELOC. If you want to
TO BYPASS THIS TEST, CALL "CODREL").
RES Writes word, increments program counter (PCNT)
SID Uses A,B,C -- Saves all
;
^CODOUT:
SKIPE NOEMIT ; GET OUT IF NO CODE IS TO BE EMITTED (I.E.
POPJ P, ; EXPR!TYPE)
PUSH P,A
PUSH P,B
SKIPE FRSTSW ;HAVE WE DONE THIS BEFORE
JRST COD1 ; YES, DON'T DO AGAIN
SETOM FRSTSW
PUSH P,LPSA ;AND SOME OTHERS
MOVEI LPSA,IPROC ;GET PROGRAM NAME.
PUSHJ P,RAD50 ;IN RADIX50
TLZ A,740000 ;RADIX50 0,NAME
MOVEM A,PRGTTL
MOVE B,BEGCNT
PUSHJ P,GBOUT ;WRITE NAME BLOCK
REN <
MOVEI A,0
SKIPN HISW ;TWO-SEGMENT PROGRAM?
JRST JUST1 ;NO
MOVE B,HBLK2 ;YES, WRITE HISEG (TYPE 3) BLOCK
PUSHJ P,GBOUT
MOVEI A,400000 ;BEGINNING PC
JUST1:
MOVEM A,BEGPC ;IN WHICH SEGMENT
>;REN
MOVE B,BEGCT2 ;CALL TO INIT & LINKAGE
PUSHJ P,GBOUT
COD2: POP P,LPSA
MOVE A,-1(P) ;RESTORE A.
COD1: TRNN A,-1 ;ZERO ADDRESS?
TLZ FF,RELOC ;YES, NO RELOC
JRST CDRL1
^CODREL:
PUSH P,A ;ENTER HERE TO BYPASS ZERO TEST
PUSH P,B
CDRL1:
HRRZ B,BINTAB ;GET COUNT
JUMPN B,BAQ ;FIRST WORD OF BLOCK?
AOS BINTAB ;YES, SET UP BLOCK
MOVE B,PCNT ;SET LOCATION WORD
MOVEM B,BINTAB+2 ;INTO 3D WORD OF BLOCK
SETZM BINTAB+1 ;CLEAR RELOCATION BITS
MOVE B,[POINT 2,BINTAB+1] ;BYTE POINTER FOR RELOC BITS
MOVEM B,CODPNT ;TO RIGHT PLACE
MOVEI B,1 ;RELOCATE THE LOC COUNTER WORD
IDPB B,CODPNT
BAQ: AOS B,BINTAB ;INCREMENT COUNT
HRRZS B ;AND MOVE TO B
MOVEM A,BINTAB+1(B) ;DEPOSIT WORD
MOVEM A,LSTWRD ;SAVE LAST WORD OUTPUT
LDB A,[POINT 1,FF,RLCPOS] ;RELOC?
SKIPE LHRELC ;RELOC LEFT HALF?
ADDI A,2 ;SAY SO
MOVEM A,LSTRLC ;AND LAST RELOCATION BIT.
IDPB A,CODPNT ;SET RELOC BITS
AOS PCNT ;INCREMENT COUNT
CAIGE B,22 ;FULL?
JRST CDRET ;NO, RETURN
MOVEI B,BINTAB ;INDICATE STANDARD COUNT AND WHICH TABLE
PUSHJ P,GBOUT ;WRITE BLOCK
; JRST CDRET
CDRET: POP P,B
POP P,A
POPJ P,
^CODLRL: ;RELOCATE LEFT HALF -- FF SAYS ABOUT RIGHT HALF
TLNE A,-1 ;NEVER RELOCATE 0
SETOM LHRELC ;SET FLAG
PUSHJ P,CODOUT
SETZM LHRELC
POPJ P,
ZERODATA( DISPLAY STUFF)
LHRELC: 0
ENDDATA
DSCR FRBT
DES Force out current binary (BINTAB) code block,
even if it's not full yet. This is done whenever
symbols or fixups which might refer to this code
are put out, so that there is something to fixup
or refer to symbolically. It is also called from DONES.
SID Saves all ACS
^FRBT: PUSH P,B
MOVEI B,BINTAB
PUSHJ P,GBOUT ;CLEAR BINARY BUFFER
POP P,B
POPJ P,
COMMENT FBOUT, etc. -- Output Fixups
DSCR FBOUT,FIXOUT,FBOSWP
DES Put word of fixup information into output file.
PAR B contains fixup specification:
lh -- PCNT of actual location of entity
rh -- PCNT of last word in fixup chain.
FBOSWP takes the above B value, swapped.
RES This word is written into the FXTAB fixup Loader
block via GBOUT (when there are enough).
FBOUT always assumes both halves reloatable
FIXOUT always assumes the actual (lh) address is not
relocatable
FBOSWP is included for convenience
SID Saves all ACs
;
^FXOSW2: MOVSS B
PUSHJ P,FIXOUT
MOVSS B
POPJ P,
^FBOSW2: MOVSS B
PUSHJ P,FBOUT
MOVSS B
POPJ P,
^FBOSWP: MOVSS B
^FBOUT: SKIPE NOEMIT ; GET OUT IF NO CODE IS TO BE EMITTED (I.E.
POPJ P, ; EXPR!TYPE)
TLNN B,-1 ;IS LEFT HALF ZERO?
ERR <DRYROT -- FBOUT>,1
TLOA FF,FFTEMP ;USE RELOCATION IN FIXUP SIDE
^FIXOUT:
TLZ FF,FFTEMP ;DO NOT RELOCATE FIXUP PART
PUSH P,B
PUSH P,A ;SAVE A
HRRZ A,FXTAB
JUMPN A,FAQ ;FIRST WORD OF BLOCK?
MOVE A,[POINT 2,FXTAB+1] ;YES, RESET RELOCATION BIT POINTER
MOVEM A,FXPNT ; (SEE CODOUT FOR SIMILARITIES)
FAQ:
AOS A,FXTAB ;INCREMENT AND FETCH COUNT
HRRZS A
MOVEM B,FXTAB+1(A) ;DEPOSIT WORD
MOVEI B,3 ;ASSUME BOTH HALVES RELOC
TLNN FF,FFTEMP ;TEST ASSUMPTION
MOVEI B,2 ; WRONG
IDPB B,FXPNT ;INSERT RELOCATION BITS
CAIGE A,22 ;FULL?
JRST FXRET ;NO, RETURN
PUSHJ P,FRBT ;FORCE OUT ANY BINARY
;(BECAUSE FIXUPS HAVE TO COME AFTER)
MOVEI B,FXTAB
PUSHJ P,GBOUT ;WRITE BLOCK
FXRET: POP P,A
POP P,B
POPJ P,
COMMENT SCOUT, etc. -- Output Symbols
DSCR SOUT,SCOUT,SHOUT,SCOUT0
DES Output symbols in RADIX50 -- many ways exist for
obtaining symbols for output, thus the proliferation.
PAR
SOUT: LPSA -- Semantics ptr. $PNAME and $ADR are used to
obtain the symbol and address.
SHOUT: LPSA -- descriptor of the form:
bits 0-5 DDT symbol type
6-17 #characters
18-35 address of string in ASCII (assumed justified)
B -- address for symbol
SCOUT: A -- RADIX50 for symbol
B -- address for symbol
SCOUT0: SAME AS SCOUT, BUT MAKES SYMBOL NON-RELOCATABLE.
SID A, TEMP, may be different on exit
;
^SHOUT: PUSHJ P,RAD52
JRST SCOUT ;MAKE RADIX50 FROM DESCRIPTOR
^SCOUT0: PUSH P,B ;NON-RELOCATED SYMBOL
MOVEI TEMP,0
JRST SASS
^SOUT: PUSHJ P,RAD50 ;GET RADIX50 FOR SYMBOL
PUSH P,B ;SAVE IT
;;# # RHT 3-19-73 MAKE RECSV SYMBOLS GO OUT UNRELOC
HRRZ B,$ADR(LPSA) ;GET ADDRESS
MOVE TEMP,$SBITS(LPSA);DOES THIS SYMBOL USE THE STACK?
TRNN TEMP,DLFLDM ;
JRST SOUT.0 ;NO
CAIGE B,20 ;HALF KILL??
TLO A,400000 ;YES
MOVEI TEMP,0 ;
JRST SASS
;;# # RHT
;;# # RHT -- 7-13-73 EXTRA KLUGE TO USE THE RAD5$ SYMBOL FOR
;; SPECIAL BILTIN RUNTIMES
SOUT.0: SETCM TEMP,$TBITS(LPSA)
TLNE TEMP,FNYNAM+OWN+EXTRNL
JRST SOUT.1 ;REGULAR
SKIPA A,RAD5$ ;PREMIUM
;;# #
^SCOUT: PUSH P,B ;SAVE
SOUT.1: MOVEI TEMP,1 ;RELOCATION BIT.
SASS: PUSH P,C
HRRZ C,SMTAB
JUMPN C,SAQ
MOVE C,[POINT 4,SMTAB+1]
MOVEM C,SMPNT
SAQ:
CAMN A,LSTRAD ;RADIX50 FOR LAST BLOCK NAME.
JRST SYMRET ;DO NOT PUT IT OUT.
AOS C,SMTAB ;BINARY DOES NOT HAVE TO BE
HRRZS B ;FORCED OUT
MOVEM A,SMTAB+1(C)
MOVEM B,SMTAB+2(C)
AOS C,SMTAB
HRRZS C
LDB B,[POINT 4,A,3] ;DON'T RELOCATE BLOCK LEVELS
CAIN B,3 ;BLOCK TYPE 14
MOVEI TEMP,0
IDPB TEMP,SMPNT
CAIGE C,22
JRST SYMRET
PUSHJ P,FRBT ;MAKE BINARY GO FIRST
MOVEI B,SMTAB
PUSHJ P,GBOUT
SYMRET: POP P,C
POP P,B
POPJ P,
COMMENT LNKOUT -- Output Linkage Block
DSCR LNKOUT --
DES Put out a (type 12) Link block via GBOUT. These blocks
allow chains of addresses to be created through separate
.REL files. STRINGC uses LINK 1 to find all its strings.
Other uses are for SETS, STRINGC routine names, and the
space allocation block.
PAR B -- link number
PCNT -- decremented by one; that is address for LINK rqst.
^LNKOUT: MOVEM B,LNKNM ;SAVE LINK NUMBER
PUSHJ P,FRBT ;NOTE DOES NOT SAVE ACS
HRRZ TEMP,PCNT
SUBI TEMP,1 ;LAST WORD OUTPUT WILL HOLD LINK
HRRZM TEMP,SLNKWD ;PLACE IN ADDR WORD OF LINK BLOCK TEMPLATE
MOVE B,SDSCRP ;DESCRIPTOR OF LINK BLOCK [COUNT,ADDR OF TEMPLATE]
PUSHJ P,GBOUT
POPJ P, ;RETURN AFTER WRITING BLOCK
COMMENT PRGOUT, FILSCN -- Output Request Blocks, Scan for Source!file Rqst
DSCR FILSCN -- CONVERT ASCII FILE-STRING TO SIXBIT
PAR PNAME, PNAME+1 describe a String representing the file
name.
RES A, C, D return DEVICE, FILENAME, and PPN in SIXBIT
DES Converts String to SIXBIT via FILNAM routine (approp-
riately informed) in Command Scanner (SAIL). Extension
not returned, because there's currenlty no need.
SID Nothing much saved
SEE FILNAM, PRGOUT, RQSET, SRCSWT
NOTENX <
^^FILSCN: SETOM TYICORE ;TYI IN COMND WILL GET CHARS FRM STRNG
PUSH P,DEVICE ;SAVE FILE DATA
PUSH P,EXTEN
PUSH P,SAVTYI
PUSH P,EOL
SETZM SAVTYI ;NO SCAN-AHEAD
MOVSI TEMP,(<SIXBIT /DSK/>) ;DEFAULT DEVICE
MOVEM TEMP,DEVICE
PUSHJ P,FILNAM ;GET SIXBITS IN NAME, EXTEN, ETC.
MOVE A,DEVICE ;LOAD RESULTS
MOVE C,NAME
MOVE D,PPN
POP P,EOL
POP P,SAVTYI
POP P,EXTEN
POP P,DEVICE ;RESTORE OLD VALUES
POPJ P,
>;NOTENX
TENX <
TFLSCN:
BEGIN TFLSCN
CTRLV__"V"-100 ;TENEX QUOTING CHARACTER
FIND__D
SETZM FIND
PUSH SP,PNAME ;ORIGINAL NAME -- COPY ONTO STACK
PUSH SP,PNAME+1
PUSH SP,[0] ;DEVICE TEMPORARY
PUSH SP,[0]
PUSH SP,[0] ;DIR TEMPORARY
PUSH SP,[0]
PUSH SP,[0] ;NAM TEMPORARY
PUSH SP,[0]
DEFINE ORIG <-7(SP)>
DEFINE ORIG1 <-6(SP)>
DEFINE DEV <-5(SP)>
DEFINE DEV1 <-4(SP)>
DEFINE DIR <-3(SP)>
DEFINE DIR1 <-2(SP)>
DEFINE NAM <-1(SP)>
DEFINE NAM1 <0(SP)>
;SIMPLE SINCE NAME IS AT THE TOP OF SP
DEFINE CATNAM (X) <
PUSH P,X
PUSHJ P,CATCHR
>
DEFINE CATDIR (X) <
PUSH P,X
PUSH SP,DIR
PUSH SP,DIR
PUSHJ P,CATCHR
POP SP,-4(SP)
POP SP,-4(SP)
>
DEFINE GCH <
HRRZ A,ORIG
JUMPE A,TENDUN
ILDB C,ORIG1
SOS ORIG
>
TENX1: GCH
CAIE C,CTRLV
JRST NOQUOTE
SKIPE FIND
JRST QUODIR
PUSHJ P,CATNA3
GCH
PUSHJ P,CATNA3 ;AND THE CHAR FOLLOWING THE CTRLV
JRST TENX1
QUODIR: PUSHJ P,CATDI3
GCH
PUSHJ P,CATDI3
JRST TENX1 ;AND CONTINUE
NOQUOTE:
CAIN C,":" ;COLON -- DEVICE
JRST ISDEV ;ITS BEEN A DEVICE ALL ALONG!!
CAIN C,","
JRST TENX1 ;IGNORE COMMA
CAIE C,40 ;SPACE
CAIN C,11 ;OR TAB
JRST TENX1
CAIE C,"<" ;THESE START THE DIRECTORY NAME
CAIN C,"["
JRST STTDIR
CAIE C,">" ;THESE FINISH THE DIR. NAME
CAIN C,"]"
JRST ENDDIR
SKIPE FIND ;DOING DIRECTORY?
JRST .+3 ;YES
PUSHJ P,CATNA3
JRST TENX1
PUSHJ P,CATDI3
JRST TENX1
STTDIR: SETOM FIND
JRST TENX1
ENDDIR: SETZM FIND
JRST TENX1
;;#SK# 5-30-74 RLS DONT MESS UP DEVICE NAME IF PRESENT
ISDEV:
MOVE C,NAM ;THE "NAME" HAS REALLY BEEN A DEV
MOVEM C,DEV
MOVE C,NAM1
MOVEM C,DEV1
SETZM NAM ;SO CLEAR THE NAME -- START OVER
SETZM NAM1
JRST TENX1
TENDUN:
;NOW STACK HAS ORIG,DEV,DIR,NAM
GOTDIR:
;NOW FIND ONLY THE NAME -- IGNORE EXTENSION, VERSION, ETC.
PUSH SP,[0] ;NEW TEMPORARY
PUSH SP,[0]
NAMLUP: HRRZ A,-3(SP)
SOS -3(SP) ;DECREMENT
JUMPE A,GOTDI1
ILDB C,-2(SP)
CAIE C,"." ;QUIT ON PERIOD
CAIN C,";" ;OR SEMICOLON
JRST GOTDI1
PUSH P,C
PUSHJ P,CATCHR
JRST NAMLUP
GOTDI1: POP SP,-2(SP) ;REMOVE TEMPORARY
POP SP,-2(SP)
HRRZ A,-1(SP) ;CHECK LENGTH OF NAME
CAILE A,6
ERR <Name too long for loader.>,1
PUSHJ P,CVSIX ;GET SIXBIT FOR NAME
MOVEM A,C ;INTO C
PUSHJ P,DIRPPN ;TRANSLATE DIRECTORY STRING TO PPN
MOVEM A,D ;PLACE PPN IN D
HRRZ A,-1(SP) ;NOW DO THE DEVICE
CAILE A,6
ERR <Device name too long for loader.>,1
PUSHJ P,CVSIX ;SIXBIT FOR DEVICE INTO A
SKIPN A ;ANYTHING THERE?
MOVE A,[SIXBIT/DSK/] ;ASSUME DEVICE DSK
SUB SP,X22 ;CLEAR OFF COPY OF PNAME
POPJ P,
;CALL CAT MACROS WITH AC C AS THE ARG
CATNA3: CATNAM C
POPJ P,
CATDI3: CATDIR C
POPJ P,
DIRPPN:
; DIRPPN -- CONVERT ASCII DIRECTORY NAME TO PPN (NEEDED FOR THE LOADER)
; PAR STRING DEVICE-NAME, DIRECTORY-NAME (ON SP STACK)
; (DEVICE-NAME IS NOT REMOVED)
; RES A: PPN
; SID SAME AS SIXBIT (EVERYTHING BUT A)
HRRZ A,-1(SP) ;IF DIRECTORY NAME LENGTH = 0
JUMPE A,DIRP.X ; RETURN(0)-ASSUME CONNECTED DIR
IFN SIXSW,< ;USE SIXBIT(DIRNAME) AS PPN
CAILE A,6 ;VERIFY THAT NAME FITS IN SIXBIT
ERR <DIRECTORY TOO LONG FOR LOADER.>,1
JRST CVSIX ; RETURN( CVSIX(ARG) )
>;IFN SIXSW
IFE SIXSW,< ;NOT SIXBIT, MORE FINAGGLING NECESSARY
; Modifications made to support TOPS20 v. 3
; Robert Smith
; Rutgers University
; March 12, 1978
; DEC has blown it! They removed the STDIR jsys, and
;changed the conventions in the emulator about directory-to-ppn
;conversion. However, there is a new JSYS, STPPN, that will
;now suffice.
; Algorithm for the following code:
;IF STDEV("NIL") fails, THEN
; BEGIN "assume TOPS20"
; AC[D] _ STPPN("<" & directory " ">" & 0);
; END ELSE
; BEGIN "assume TENEX"
; rh of AC[D] _ STDIR(directory & 0);
; END;
BEGIN DIRNAME
EXTERN CHRCAT,$OSTYP
PUSH P,B ;SAVE B
SKIPE $OSTYP ;[CLH] IS IT TENEX?
JRST TOPS20 ;NO--MUST BE TOPS20
PUSH P,[0] ;MAKE STRING ASCIZ BY APPENDING
PUSHJ P,CATCHR ;NULL BYTE TO END OF STRING
MOVE B,(SP) ;BP TO ASCIZ
MOVEI A,1 ;POSITIVE -- NO RECOGNIZE
JSYS STDIR ;TWO ERROR RETURNS (+1 AND +2)
JFCL ;HANDLE IDENTICALLY
JRST [ERR <This directory does not exist on this system.>,1
SETZ A, ;RESULT 0(CONNECTED DIRECTORY)
JRST CLNUP ;AND CLEANUP
]
HRLI A,4 ;4,,DIRNO
JRST CLNUP ;CLEANUP STACK AND RETURN
;HERE WITH TOPS20
;FIRST BUILD A STRUCTURE NAME
;SP STACK:
; DEVICE-NAME
; DIRECTORY-NAME
TOPS20: ;
;FIRST SURROUND DIRECTORY-NAME WITH "<>" PAIR
PUSH P,[74] ;LEFT BROKET
PUSHJ P,CHRCAT
PUSH P,[76] ;RIGHT BROKET
PUSHJ P,CATCHR
;NOW SEE IF THERE IS A DEVICE NAME
HRRZ B,-3(SP) ;IF NOT LENGTH(DEVICE-NAME)
JUMPE B,NODEVN ;THEN GOTO NODEVN
PUSH SP,-3(SP) ;DEVICE-NAME
PUSH SP,-3(SP)
PUSH P,[":"] ;WITH A COLON
PUSHJ P,CATCHR
PUSH SP,-3(SP) ;DIRECTORY-NAME
PUSH SP,-3(SP)
PUSHJ P,CAT ;
POP SP,-2(SP) ;CLOBBERS DIRECTORY-NAME ON
POP SP,-2(SP) ;STACK
NODEVN:
PUSH P,[0] ;PREPARE FOR STPPN
PUSHJ P,CATCHR ;AND PUT A NULL ON THE END ;
MOVE A,0(SP) ;STRING POINTER
OPDEF STPPN [104000000556]
STPPN ;PPN IN REG A
JUMP 16,[ERR <This directory does not exist on this system.>,1
SETZ A, ;RESULT 0(CONNECTED DIRECTORY)
JRST CLNUP ;AND CLEANUP
]
MOVEM B,A ;FOR RETURN
CLNUP: POP P,B ;RESTORE B
BEND DIRNAME
>;IFE SIXSW
DIRP.X: SUB SP,X22 ;REMOVE ARGUMENT FROM SP
POPJ P, ;AND LEAVE
BEND TFLSCN
>;TENX
DSCR PRGOUT -- OUTPUT PROGRAM AND LIBRARY REQUEST BLOCKS
DES Output (via GBOUT) Program and Libraray REQUEST BLOCKS.
PAR B ptr to PRGTAB or LBTAB (program or library request)
PNAME, PNAME+1 as in FILSCN
Defaults as in FILSCN; DEVICE, FILE and PPN will be passed
to the loader.
RES FILSCN is called to make SIXBIT representations of DEVICE,
FILE, and PPN; these are placed in the output block.
SID Saves the world
;
^^PRGOUT:
NOTENX<
MOVE USER,GOGTAB ;SAVE ACS IN USER TABLE AREA
HRRZI TEMP,RACS(USER)
BLT TEMP,SBITS2+RACS(USER) ;FILNAME USES MANY ACS
PUSHJ P,FILSCN ;GET SIXBITS IN A,C,D
MOVE B,RACS+2(USER) ;GET TABLE ADDRESS BACK
MOVEI TEMP,3 ;PREPARE TO COUNT UP BLOCK COUNT
ADDB TEMP,(B)
ADDI TEMP,(B) ;ptr to AREAS TO BE FILLED
MOVEM C,-1(TEMP) ;STORE NAME
;;=I10= SFD PATCH - BE SURE WE HAVE A REAL PPN
SFDS<
JUMPE D,.+3 ;ZERO PPN IS OK
TLNN D,777777 ;SO IS A REAL PPN
;;JOHN - POSSIBLE YOU WANT TO ISSUE AN ERROR MESSAGE HERE INSTEAD
MOVE D,2(D) ;IF PATH PTR, USE PPN FROM PATH
> ;SFDS
MOVEM D,00(TEMP) ;STORE PPN
MOVEM A,01(TEMP) ;STORE DEVICE
TYMSHR<
JUMPE D,PRGOU2 ;IF NO PPN
TLNN D,-1 ;OR IF REAL PPN
CAME A,[SIXBIT /DSK/] ;OR NOT DISK
JRST PRGOU2
MOVE C,AVLSRC
JFFO C,.+2
JRST PRGOU2
CAILE D,17
JRST PRGOU2 ;FIND CHANNEL
PUSH P,B
MOVSI A,(<RELEASE>)
DPB D,[POINT 4,A,12]
PUSH P,A
MOVE A,[LOOKUP A]
DPB D,[POINT 4,A,12]
PUSH P,A
MOVE A,[OPEN B]
DPB D,[POINT 4,A,12]
MOVEI B,16
MOVSI C,'DSK'
MOVEI D,0
XCT A
JRST PRGOU3
MOVEI A,3 ;NOW LOOKUP
MOVE B,(TEMP)
MOVE C,-1(TEMP)
MOVEI D,0
XCT (P)
JFCL
MOVEM B,(TEMP) ;SAVE PPN
PRGOU3: POP P,A
POP P,A ;THE RELEASE
XCT A
POP P,B
PRGOU2:>
>;NOTENX
TENX<
PUSH P,A ;MUST PUSH SINCE TFLSCN CALLS RUNTIMES
PUSH P,C
PUSH P,D
EXCH SP,STPSAV ;GET A STRING STACK
PUSHJ P,TFLSCN ;DOES NOT MODIFY B
EXCH SP,STPSAV ;RESTORE IT
MOVEI TEMP,3
ADDB TEMP,(B)
ADDI TEMP,(B) ;ptr to AREAS to be filled
MOVEM C,-1(TEMP) ;STORE NAME
MOVEM D,00(TEMP) ;STORE PPN
MOVEM A,01(TEMP) ;STORE DEVICE
POP P,D
POP P,C
POP P,A ;RESTORE
PUSH P,TEMP
MOVE USER,GOGTAB ;SAVE FOR KROCK BELOW
HRRZI TEMP,RACS(USER)
BLT TEMP,SBITS2+RACS(USER)
POP P,TEMP
>;TENX
HRRZS TEMP
CAIL TEMP,22(B) ;BLOCK FULL?
PUSHJ P,GBOUT ;YES, PUT IT OUT
HRLZI TEMP,RACS(USER)
BLT TEMP,SBITS2
POPJ P, ;TRA 0,4?
SUBTTL Generator Miscellaneous.
COMMENT RAD50, RAD52 -- Radix-50 Functions for Scout Routines
DSCR RAD50,RAD52 -- create a RADIX50 symbol
PAR RAD50 -- LPSA pntr to block head -- string is in $PNAME, etc.
RAD52 -- LPSA(lh) is count, LPSA (rh) is address of string,
assumed aligned.
RES RADIX50 for symbol in A
SID Results in A, all other ACS saved (except TEMP)
;
^RAD50:
EXCH SP,STPSAV
MOVSS POVTAB+6 ;ENABLE FOR STRING PDL OV
PUSH SP,$PNAME(LPSA) ;COLLECT POINTERS IN COMMON SPOT
PUSH SP,$PNAME+1(LPSA)
HRRZS -1(SP) ;CLEAR STRNO, SAVE COUNT
MOVE A,$TBITS(LPSA) ;CONTROLS MODE BITS IN RAD50 SYMBOL
MOVEI TEMP,10/4 ;ASSUME LOCAL
TLNE A,INTRNL ;INTERNAL IS TYPE 4
MOVEI TEMP,4/4
TLNE A,EXTRNL
MOVEI TEMP,60/4 ;EXTERNAL IS TYPE 60
MOVEI A,0 ;INITIALIZE A
JRST RAD5
^RAD52:
LDB TEMP,[POINT 12,LPSA,17] ;COUNT
EXCH SP,STPSAV
MOVSS POVTAB+6 ;ENABLE FOR STRING PDLOV
PUSH SP,TEMP
PUSH SP,LPSA ;MAKE IT LOOK LIKE STRING
HRRI TEMP,(<POINT 7,0>) ; DESCRIPTOR
HRLM TEMP,(SP)
MOVEI A,0
LDB TEMP,[POINT 4,LPSA,3]
RAD5: PUSH P,TEMP
PUSH P,B ;SAVE IT
MOVEI TEMP,6
R50LUP: SOSGE -1(SP) ;QUIT IF NO MORE STRING
JRST R5OUT
ILDB B,(SP) ;CHARACTER
CAIN B," " ;IGNORE BLANKS ABSOLUTELY!
JRST R50LUP ; THIS RUNS ALL THE CHARACTERS TOGETHER
CAIL B,"a"
CAILE B,"z"
JRST .+2
SUBI B,40 ;CONVERT TO UPPER CASE
CAIE B,30 ;UNDERLINE:THESE CHARS HAVE TO BE CREATED INDIVIDUALLY
CAIN B,"."
MOVEI B,66+45 ;RAD50 CHAR FOR "." + 66 TO BE SUBTRACTED
;;#GQ# DCS 2-8-72 (1-1) ! SAME AS UNDERLINE
CAIN B,"!" ;! SAME AS UNDERLINE
MOVEI B,66+45 ;"."
;;#GQ# (1)
CAIN B,"$"
MOVEI B,66+46
CAIN B,"%"
MOVEI B,66+47
SUBI B,66 ;OK IF A LETTER
CAIG B,12 ;<12 IF A NUMBER
ADDI B,7 ; THIS MAKES IT RIGHT
IMULI A,50 ;THAT'S THE NUMBER ALL RIGHT
ADD A,B ;COLLECT RADIX50
SOJN TEMP,R50LUP ;QUIT AT 6
R5OUT: MOVEM A,RAD5. ;NOW CREATE SAME SYMBOL WITH
JUMPLE TEMP,MORFIV ;MORE THAN FIVE CHARS?
IMULI A,50 ;MAKE IT "SYMB".
SKIPA
MORFIV: SUB A,B ;"." IN PLACE OF THE LAST
POP P,B ;RESTORE B
POP P,TEMP ;TYPE BITS.
DPB TEMP,[POINT 4,A,3] ;TYPE BITS TO RADIX 50
ADDI A,46 ;$
MOVEM A,RAD5$
ADDI A,1 ;%
MOVEM A,RAD5% ;
SUBI A,2 ;"."
EXCH A,RAD5. ; AND STORE IT IN RAD5. FOR STRINGS
DPB TEMP,[POINT 4,A,3] ;TYPE BITS TO RADIX 50
SUB SP,X22
EXCH SP,STPSAV ;RESTORE REGS
MOVSS POVTAB+6 ;RE-ENABLE FOR PARSE PDLOV
POPJ P,
BEND TOTAL
IFN FTDEBUG, <^INNA_INNA>