Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0003/pasio.mac
There are 4 other files named pasio.mac in the archive. Click here to see a list.
title PASIO - I/O routines for TOPS-20 Pascal
;edit history - begins with edit 2
;2 - keep disk open from blowing up when file has byte size of 0
;3 - improve recovery from arithmetic errors
;4 - set up to process pushdown overflow
;5 - Tenex
;6 - replace pasin. by pasif., which doesn't use pushj, in case
; emulator is active (as it is for tenex)
;7 - more Tenex, convert some more erjmp's to erjrst, gnjfx1
; end of line for tty I/O
; tty openned as file should still use pstin
;10 - add multiple page buffers. This involves major edits to the
; whole map I/O section, getpag/relpag, and the callers thereof
; I have not put edit numbers on this edit.
;11 - remove DMOVE, for KA Tenex
;12 - mark file as unopened after closing it
;13 - fix open of TTY and TTYOUTPUT, since edit 12 broke it
;14 - general Tenex TTY I/O, supposedly the INTERLISP-style line
; Few TENEX sites support the PSTIN JSYS.
;15 - fix up what we do on errors a bit
;16 - use GET. instead of GET; don't look for line numbers unless
; first word of file is line numbered (undone in edit 23, except SRI)
;17 - don't do line number test for size=0. For version 1 monitors. We
; would get ill mem read, since ERJMP didn't always work in version 1.
;20 - replace newpage,retpage with getpages,relpages. Move old ones to PASOLD
;21 - Add code for Tenex with PA2040
;22 - fix f%ltst routine so it doesn't need to use BKJFN, since that won't
; work for tapes [monitor bug]. NB: Originally, we tested every word
; in the file to see if it was a line number. I still prefer that code.
; The business of testing the first word and turning off the test if it
; is not a line number is done strictly for SRI. The code is ugly, in
; in case of errors in reading the first word, who knows what to do?
; The reason SRI needs it is because their version of EMACS randomly
; sets the low order bit in files it creates.
;23 - put funny line number testing under SRI conditional
;24 - add code for dynamic heap management (DDyer@USC-ISIB)
;25 (DFloodPage@BBNE) use non-binary mode in RDSTR on Tenex
; Don't set bit zero in chfdb on Tenex
;26 - missing PSOUT of prompt in error handling
;27 - all continuation after quota exceeded. This is a "temporary" fix.
; A more general redesign to allow continuation in all cases
; is in PASIO.NEW. However it is going to be a bear to debug, so
; this patch is being used as a safe one that does the job.
;30 - replace WRTPC with RUNERR, that allows continuation
;31 - new routines - SHOWLN and FIXLN
;32 - add TTYPR. - prompt for INPUT open on TTY:
;33 - retry opens when something goes wrong
;34 - new intelligible form for funny open options
;35 - minor fix to maperr, for holes in file
;36 - removed setting EOLN in CLREOF
;37 - typo: had move instead of movei at HAVSPC
;40 - handle zero counts for SOUT, SOUTR, and SINR
;41 - fix bad stack offset
;42 - fix CLREOF - AC 2 was being garbaged
;43 - fix NEWCL. - had reversed AC 1 and 2
sall ;no macro bodies or repeats
search monsym,pasunv
if1,<
ife tenex,<printx Tops-20 version>
ifn tenex,<
ifn sumex,<printx Sumex version>
ife sumex,<
ifn pa2040,<printx Tenex PA2040 version>
ife pa2040,<printx Tenex non-PA2040 version>
>;ife sumex
>;ifn tenex
ifn srisw,<printx SRI line number kludge included> ;[23]
>;if1
gnjfx1=601054 ;[7] T20 calls this gnjfx1, Tenex gnjfx2. In
;[7] Tenex gnjfx1 is something else. So this
;[7] definition should let us transport the code.
ifn sumex,<
opdef pstin [jsys 611] ;[14] SUMEX has PSTIN, so does IMSSS, but nowheres
;[14] else is it guaranteed! Thus, where the
;[14] SUMEX switch is not, we simulate the
;[14] INTERLISP string reading stuff
>
mapbfs==4 ;default number of pages in buffer for mapped I/O
ifn tenex,<mapbfs==1> ;except for Tenex, no advantage to more than 1
;[the code should work for .gt. 1 even in tenex, though]
oldcom==1 ;kludges needed to run this with .rel files made
;by the tops-10 compiler (alas, I have never removed
;the last vestiges of this program structure. So this
;switch is mostly a comment showing what should be
;cleaned up.)
entry initb.,init.b
entry endl,runer.,gotoc.,dispc.,ilfil.
entry resetf,rewrit,getch,get.,putch,put,clofil,getchr
entry getfn.,getln,putln,putpg,getlnx,putlnx,putpgx
entry putx,getx.,break,breaki
entry setpos,curpos
entry pasin.,pasif.,end,quit,clreof,getpg.
entry newbnd,corerr,lstnew,illfn,norcht,norchx
entry inxerr,ptrer.,srerr
entry getnew,newcl.
entry rename,delf.,append,update,resdev,relf.,nextfi
entry erstat,analys,lstrec
entry ttypr.
twoseg
.jbren==124
loc .jbren
exp quit
reloc 0
frepag: block 17 ;array of bits to indicate free pages
lstnew: block 1 ;last location used by new
ifn oldcom,<
newbnd: block 1 ;dummy for tops-10 code
> ;ifn oldcom
reloc 400000
ife tenex,< ;[27]
;
;CHKQUO should be used after any JSYS that might get a disk quota overflow.
; Note that it can be followed by an ERCAL or ERJMP, which will activate
; if any other error condition is present.
;CHKQUO should not be used after ILDB or IDPB. ERCAL MAPERR is the
; canonical error handler for that. MAPERR handles quota errors itself.
define chkquo,< ercal quochk>
> ;ife tenex
ifn tenex,<
define chkquo,<> ;[27]
ife sumex,< ; TENEX GETER loads 4-10 with PSB
define geter,< pushj p,.geter >
.geter: push p,4
push p,5
push p,6
push p,7
push p,10
jsys 12 ; geter
pop p,10
pop p,7
pop p,6
pop p,5
pop p,4
popj p,
>
>
ifn oldcom,<
;This routine will be called once in initialization to create core
;for the beginning of the stack. After that core will be created
;automatically, as the nxm interrupt will be off.
corerr: move d,a ;save return address
movei a,400000 ;current process
movei 2,1b22 ;nxm interrupt
dic ;disable interrupt
move a,(p) ;reference the location
movei n,777777 ;set so we are never called again
jrst (d) ;return
> ;ifn oldcom
GETNEW: movn a,b ;must be interruptible
addb a,lstnew ;get new addr and update lstnew at once
cain a,377777 ;if result is nil
jrst newnil ; get another one!
camge a,.jbff## ;overlap low?
jrst nonew ;yes, nothing there
newxit: move b,a
popj p,
newnil: caig b,0 ;if size 0, adjust to 1 so we go somewhere
movei b,1
jrst getnew ;and try again
;[43] reverse roles of a and b after call to NEW, remove call to
;NEWXIT, which had been used to get value back in b
newcl.: push p,b ;here to clear result
pushj p,new##
pop p,a
jumple a,cpopj ;if 0, nothing to clear
setzm (b) ;clear first
sojle a,cpopj ;anything else to clear?
add a,b ;last address
hrli t,(b) ;first address
hrri t,1(b) ;make blt for clear
blt t,(a)
popj p,
;Here if nothing more available
nonew: move t,(p) ;this is addr for error printer
pushj p,newerr
movei b,377777 ;return NIL if he tries to continue
popj p,
define outstr(x),<
hrroi a,x
psout >
define eoutstr(x),<
hrroi a,x
esout >
;runer. - general-purpose routine for processing runtime errors.
; if t matters to a continuation, we assume it has been saved at erracs
; t - addr of PC to print out
; pushj p,runer.
; here if user continues (after correcting error, one hopes)
;This routine prints a PC, then either goes to a debugger (if there
;is any) or warns the user that continuation is at his own risk.
;If there is any reason to believe that P is blown, you had better
;supply a good one before calling this guy.
reloc
ddtgo: block 1
erracs: block 20
reloc
runer.: movem 0,erracs ;save the AC's
move 0,[xwd 1,erracs+1]
blt 0,erracs+17
move 0,erracs
outstr [asciz / at user PC /]
psout
;print PC in octal
HRRZI d, 6
MOVE e,[POINT 3,t,17]
ILDB a, e
ADDI a, 60
pbout
SOJG d,.-3
;go to debugger if there is any
HRRZ c,.JBDDT## ;[3] LOAD PASDDT-ADDR
JUMPE c,noddt ;[3] no .jbddt, maybe vmddt
move c,.jbddt## ;[3] want left half, too
tlze c,777777 ;[3] if zero, it is PASDDT
jrst decddt ;[3] if not, real DDT
;PASDDT
pushj p,-1(c) ;[3] go to pasddt special entrance
jrst errest ;continue if he continues
;nothing obvious - check for VM DDT or just halt
noddt: move a,[xwd 400000,770] ;[3] no .jbddt, see if 770000
rpacs ;[3] page exist?
tlnn b,(pa%pex) ;[3]
jrst hlterr ;[3] no - continue
tlnn b,(pa%ex) ;[3] allowed to execute?
jrst hlterr ;[3] no - continue
;DDT
movei c,770000 ;[3] seems to be ddt - get its addr
decddt: movem t,.jbopc## ;save PC so he can continue
hrrzm c,ddtgo
outstr [asciz /
[Type POPJ 17,$X to continue if possible
QUIT$G to close files and exit]
/]
move 0,[xwd erracs+1,1] ;restore ac's to pgm context
blt 0,16
move 0,erracs
pushj p,@ddtgo ;[3] avoid -1 entry point!
jrst errest ;continue if he exits
;no debugger, just halt and let him go on if he dares
hlterr: move b,.jbren
movei a,[asciz /
[Type CONTINUE to proceed if possible.]
/]
cain b,quit ;if user hasn't set his own REE trap
movei a,[asciz /
[Type CONTINUE to proceed if possible,
REENTER to close all files and exit.]
/]
psout
haltf
; jrst errest
;here to continue if the user really wants to
errest: move 0,[xwd erracs+1,1]
blt 0,17
move 0,erracs
popj p,
ilfil.: eoutstr [ASCIZ /Uninitialized file/]
move t,(p)
pushj p,runer.
movei b,tty## ;use tty instead
popj p,
INXERR: eoutstr [ASCIZ /Array index out of bounds/]
pushj p,runer.
jrst @t
newerr: eoutstr [asciz /No memory for heap/]
pushj p,runer.
popj p,
PTRER.: eoutstr [ASCIZ /Uninitialzed or NIL pointer/]
pushj p,runer.
jrst @t
SRERR: eoutstr[ASCIZ/Scalar out of range/]
pushj p,runer.
jrst @t
blktbe: push p,t
setz t, ;we don't know the location
eoutstr[ASCIZ/Too many files open at once/]
pushj p,runer.
pop p,t
popj p,
subttl file openning - top level routines
;ac usage for the file openning routines:
; t,a - temporary
; b - fcb
; c - string (file spec)
; d - length of string
; e - protection/interactive
; f - gtjfn word or 0
; g - openf word or 0
; h - bits:
; fl%lc (1) map lower case
; fl%ioe (2) handle i/o errors
; fl%fme (4) handle data format errors
; fl%ope (10) handle open errors
; fl%eol (20) show end of line char
; fl%buf (7700) number of buffers or pages
; fl%mod (770000) I/O type
; fm%byt(1) bin/bout
; fm%map(2) pmap
; fm%tty(3) texti/bout
; fm%nul(4) popj
; fm%wrd(5) buffered 36 bit
; fm%chr(6) buffered logical byte size
; fm%lst last legal mode
;places to save f and g for retry
filsvf==filst5
filsvg==fils21
;The following define flags we can't let the user play with. We set
; flags first by zeroing these and then doing tlc with those we want
; to set. This results in the settings needed for the bits listed
; here, but lets the user clear others that we set by specifying
; them in his argument.
gj%reg==gj%flg!gj%sht!gj%jfn!gj%ofg!gj%xtn
of%reg==of%rd!of%wr!of%ex!of%app
resetf: movei t,0 ;eof setting for correct operation
pushj p,setprm ;initialize fcb
tlz f,(gj%reg)
tlc f,(gj%old!gj%flg!gj%sht) ;extra bits for gtjfn
trz g,of%reg
trc g,of%rd ;extra bits for openf
pushj p,getjfn
pushj p,devprm ;device-dependent parameter setting
pcall f%open
pcall f%ltst
pushj p,errchk ;if open errors
jrst resetf ;then try again
hlre c,filcnt(b) ;get count in case record I/O
movn c,c ;is negative
jumpe e,@filget(b) ;if not interactive, get 1st thing
skipn filerr(b) ;any errors in openning?
aos fileol(b) ;no - set dummy eoln for interactive begin
cpopj: popj p,
update: movei t,0 ;eof setting for correct operation
pushj p,setprm ;initialize fcb
tlz f,(gj%reg)
tlc f,(gj%old!gj%flg!gj%sht) ;extra bits for gtjfn
trz g,of%reg
trc g,of%rd!of%wr ;extra bits for openf
pushj p,getjfn
pushj p,devprm ;device-dependent parameter setting
pcall f%open
pcall f%ltst
pushj p,errchk ;errors?
jrst update ; yes - try again
skipn filerr(b) ;any errors in openning?
aos fileol(b) ;no - set dummy eoln for interactive begin
popj p,
rewrit: movei t,1 ;eof setting for correct operation
pushj p,setprm ;initialize fcb
tlz f,(gj%reg)
tlc f,(gj%fou!gj%flg!gj%sht) ;extra bits for gtjfn
trz g,of%reg
trc g,of%wr
pushj p,getjfn
pushj p,devprm ;device-dependent parameter setting
pcall f%open
pushj p,errchk ;errors
jrst rewrit ;yes - try again
popj p,
append: movei t,1 ;eof setting for correct operation
pushj p,setprm ;initialize fcb
tlz f,(gj%reg)
tlc f,(gj%old!gj%flg!gj%sht) ;extra bits for gtjfn
trz g,of%reg
trc g,of%app
pushj p,getjfn
pushj p,devprm ;device-dependent parameter setting
pcall f%open
pushj p,errchk ;errors?
jrst append ;yes - try again
popj p,
subttl rename and delete
rename: push p,filjfn(b) ;save old jfn
push p,b
push p,c
movsi c,(co%nrj) ;close but leave jfn
pushj p,doclos
pop p,c
pop p,b
setzm fileof(b) ;assume it is OK
setzm filerr(b) ;so getjfn works
tlz f,(gj%reg)
tlc f,(gj%fou!gj%flg!gj%sht)
pushj p,getjfn ;get new jfn
skipe filerr(b) ;if error, stop now
jrst rener1
move h,b ;protect fcb and put where doope wants
pop p,a ;old jfn
tlz a,-1
hrrz b,filjfn(h) ;new jfn
rnamf
erjrst rener ;[7]
popj p,
rener: hrrzm a,filerr(h) ;this is error code
aos fileof(h) ;set eof
popj p,
rener1: movei a,1
movem a,fileof(h) ;set eof
popj p,
delf.: push p,filjfn(b)
push p,b
push p,c
movsi c,(co%nrj)
pushj p,doclos
pop p,c
pop p,b
setzm fileof(b)
setzm filerr(b)
pop p,a
hrli a,(df%nrj) ;keep the jfn
move h,b ;where rener needs it
delf
erjrst rener ;[7]
popj p,
subttl low level routines for file openning
;AC usage for setprm:
; t - at entry, this is normal setting of eof
; a - length of file component, 0 if text
; b - fcb pointer
; c - lh=flags, rh=addr of file spec
; d - length of file spec
; e - 0 or 1 - interactive flag; more commonly - new funny option string
; h - flags
; t,a garbaged
;setprm handles all device-independent file-openning stuff,
;including initializing the fcb so all entries are valid for I/O.
;In case of error, filerr is set, so the caller had better check
;this. Byte size and I/O routines are left for devprm, as they
;are device-dependent.
setprm:
;First we make sure we have a valid FCB
push p,t
move t,filtst(b)
caie t,314157 ;magic word will be there if it is legal
pushj p,initb. ;not - init it
pop p,t
;We do any format conversions before saving away the values
ifn oldcom,<
camn h,[-1] ;old compiler uses -1 as default
setz h, ;should be 0
> ;ifn oldcom
came e,[exp -1] ;-1 or 0 LH is probably old format
tlnn e,777777
jrst setpr1 ;old format
pushj p,option ;new format parse options
;now save values in case of restart. Note that format conversions won't be
;redone in case of restart since LH(e) is now 0, and h is not longer -1
setpr1: movem f,filsvf(b) ;save args for error recovery
movem g,filsvg(b) ; h is also saved, below - e is not touched
movem t,fileof(b) ;put in a few args
trc t,1 ;this is the eof to set if errors
movem t,filbad(b)
movn a,a ;filcnt wants negative count
hrl a,a ; in left,
hrri a,filcmp(b) ; with addr of buffer in RH
movem a,filcnt(b)
;the following code is intended to set both H and FILFLG to
; H*(-20) + FILFLG*20.
trz h,fl%tmp ;H * (-20)
exch h,filflg(b) ;reverse them so we can play with FILFLG
andi h,fl%tmp ;FILFLG * 20
iorb h,filflg(b) ;both _ H * (-20) + FILFLG * 20
;here we figure out which character table to use
movei a,0 ;assume no lc map, standard EOL treatment
trne h,fl%lc ;if lc mapping on
tro a,2 ;set bit 2
trne h,fl%eol ;if we want to see EOL char
tro a,1 ;set bit 1
move t,[exp norchx,norcht,lcchx,lccht](a) ;get the right table
hrli t,a ;indexed on this ac
movem t,filcht(b)
;now random initialization
movei a,filcmp(b)
movem a,filptr(b)
move a,[ascii /-----/] ;initial line number
movem a,fillnr(b)
push p,c
movsi c,(co%nrj) ;assume we use existing jfn
skipn d ;unless new file spec
skipge (p) ;or request to get spec from tty
setz c, ; then full close
pushj p,doclos ;close file if one already open
;becaue of code above, this also releases the jfn
;and zeros filjfn if the user gave us a new file spec
pop p,c
setzm filerr(b) ;now zero things
setzm fileol(b)
setzm fillts(b)
move a,filcnt(b) ;zero the component
setzm (a)
aobjn a,.-1
ifn oldcom,<
caie b,tty## ;special for tops-10 tty open, since
cain b,ttyout## ;args are garbage
jrst opntty
> ;ifn oldcom
popj p, ;no - done
;e - LH - count, RH - addr
option: push p,t
push p,a ;get some working space
push p,b
hlrz a,e ;a _ count
hrrz t,e ;t _ byte ptr
setz e, ;e is now one of the AC's we are setting up
hrli t,440700
jumpe a,optend
optlop: ildb b,t ;b _ next char
caie b,"/" ;use / to separate options
jrst opterr ;error
sojle a,opterr ;count /, there had better be letter following
ildb b,t ;b _ option letter
soj a, ;count the letter
caile b,140 ;if lower case
subi b,40 ;make it upper
cail b,optmin ;if below first
caile b,optmax ;or above last
jrst opterr ;error
xct opttab-optmin(b) ;appropriate processing routine
jumpg a,optlop ;if any more char's, get next
optend: pop p,b ;exit
pop p,a
pop p,t
popj p,
optmin="B"
opttab: pushj p,optbyt ;B - byte size
jrst opterr ;C - undef
tro h,fl%ioe ;D - data trans errors
tro h,fl%eol ;E - show eoln
tro h,fl%fme ;F - data format errors
jrst opterr ;G - undef
jrst opterr ;H - undef
movei e,1 ;I - set interactive flag
repeat "M"-"J",< jrst opterr> ;J to L - undef
pushj p,optmod ;M - mode
jrst opterr ;N - undef
tro h,fl%ope ;O - open errors
repeat "S"-"P",< jrst opterr> ;P to R - undef
pushj p,numbuf ;S - buffer size
jrst opterr ;T - undef
tro h,fl%lc ;U - lower to upper
optmax=="U"
optmod: pushj p,optdec ;parse a decimal number
lsh b,^D12 ;shift it to mode position
or h,b ;and or into flags
popj p,
numbuf: pushj p,optdec ;parse decimal
trne b,777 ;any odd words?
addi b,1000 ;yes - round up pages
lsh b,^D-9 ;pages
lsh b,6 ;shift into page count
or h,b
popj p,
optbyt: pushj p,optdec ;parse a decimal number
lsh b,^D30 ;shift it to the byte position
or g,b ;and or into open bits
popj p,
optdec: push p,c
push p,d
sojle a,opterd ;count colon, better be an extra after that
ildb b,t
caie b,":"
jrst opterr
setz c, ;accumulate number in c
optdcl: ildb b,t
cail b,"0"
caile b,"9"
jrst opterd
subi b,"0"
imuli c,^D10
add c,b
sojle a,optdcx ;count digit, if end of string, done
move d,t ;peek at next
ildb b,d
cain b,"/" ;if /, this is end
jrst optdcx
jrst optdcl ;really get char
optdcx: move b,c ;return value in b
pop p,d
pop p,c
popj p,
opterd: pop p,d
pop p,c
pop p,(p)
opterr: move b,a ;save a
hrroi a,[asciz / Error in option string/]
esout
move t,-4(p) ;-2 for saved args, -2 because called 2 deep
pushj p,runer.
jrst optend ;return from OPTION
ifn oldcom,<
opntty: aos fileol(b) ;always interactive
hrli t,ttynt ;[13] copy special tty dispatch table
hrri t,filr11(b) ;[13] since rest of open won't be done
blt t,filr99(b) ;[13]
pop p,(p) ;exit from caller
popj p,
> ;ifn oldcom
;AC usage for devprm
; b - fcb
; g - openf word
; h - used internally for dvchr flags
; t,a,c,h garbaged, g updated
;devprm sets up device-dependent parameters in the fcb, mainly
;byte size and I/O routines.
devprm: skipe filerr(b) ;no-op if error already
popj p,
move h,b ;save fcb over dvchr call
hrrz a,filjfn(b)
dvchr
erjmp doope
ifn tenex,<push p,a> ;[7] save designator in case of tty
exch h,b ;result of dvchr to h, fcb to b
;now we set up proper device/function dependent table
ldb a,[fl%mod!filflg(b)];get user specified mode
caig a,fm%lst ;unimplemented gets default
jumpn a,devfnd ;if he gave one, use it
movei a,fm%byt ;else, byte I/O is default
hlrz h,h ;get dv%typ field
andi h,(dv%typ) ;code from here to devfnd sets
cain h,.dvdsk ; a to Pascal mode
movei a,fm%map
cain h,.dvtty
movei a,fm%tty
cain h,.dvnul
movei a,fm%nul
cain h,.dvmta
ife tenex,<movei a,fm%mta>
ifn tenex,<movei a,fm%wrd>
caie h,.dvcdr
cain h,.dvlpt
movei a,fm%chr
devfnd:
ifn tenex,< ;[7] if tty, see if ours
cain a,fm%tty ;[7] tty mode?
pushj p,devtty ;[7] yes, turn to fm%chr if not ctrl term
adjstk p,-1 ;[7] a was saved
> ;ifn tenex
movsi t,070000 ;default byte size
skipge filcnt(b) ;except for record I/O
movsi t,440000 ;default is 36
tlnn g,(of%bsz) ;if user defaulted it
ior g,t ;then use our default
;special entry for mtaopn
setdsp: subi a,1 ;now set dispatch vector per a
lsh a,1 ;a _ (a - 1) * 2
skipge filcnt(b) ;if record I/O,
addi a,1 ;use second column in table
hrl t,devtab(a) ;get address of disp. vec. from table
hrri t,filr11(b) ;whre to copy vector
blt t,filr99(b)
popj p,
ifn tenex,< ;[7]
;this code is to see whether a tty is the controlling terminal.
; If so, we use pstin. Otherwise, you get the losing BBN type mode.
devtty: push p,b
hrroi a,[asciz /TTY/] ;get designator for own tty
stdev
jrst [adjstk p,-3
jrst doope]
movei a,fm%tty ;assume ours
came b,-2(p) ;compare with dev designator saved
movei a,fm%byt ;not ours, use bin/bout
pop p,b
popj p,
> ;ifn tenex [7] ^^
;here is the table of dispatch vectors
;text, record
fm%mta==0 ;pseudo-mode that sets defaults after looking at label type
exp mtatxt, mtarec
devtab: exp byttxt, bytrec
exp maptxt, maprec
exp ttytxt, ttyrec
exp nultxt, nulrec
exp wrdtxt, wrdrec
exp chrtxt, chrrec
exp rectxt, recrec
;here are the tables referred to in the matrix
; byte-size,getch,putch,getln,putln,close,dispatch
; getx,putx,putpage,setpos,curpos,init,open,break,lintst
; showln,fixln
byttxt: exp getchx,putchx,getlnx,putlnx,0,.+1
exp illfn,illfn,putpgx,setpbx,curpbx,cpopj,openfi,cpopj,cpopj
exp showln,notry
bytrec: exp getbx,putbx,illfn,illfn,0,.+1
exp getxbx,putxbx,illfn,setpbx,curpbx,bxini,bxopn,cpopj,cpopj
exp showln,notry
maptxt: exp getchd,putchd,getlnx,putlnx,dskclo,.+1
exp illfn,illfn,putpgx,dskspo,dskcpo,dskbri,dskopn,dskbrk,dsklts
exp showln,notry
maprec: exp getd,putd,illfn,illfn,dskclo,.+1
exp getxd,putxd,illfn,dskspo,dskcpo,dskbri,dskopn,dskbrk,cpopj
exp showln,notry
ttytxt: exp getcht,putchx,getlnx,putlnx,0,.+1
exp illfn,illfn,putpgx,setpt,curpbx,ttyini,tdvopn,cpopj,cpopj
exp tdvshl,tdvfxl
ttyrec==bytrec ;not sure this is right. What is record I/O on tty?
nultxt: exp simeof,cpopj,simeof,cpopj,0,.+1
exp illfn,illfn,cpopj,nulspo,retzer,cpopj,openfi,cpopj,cpopj
exp showln,notry
nulrec: exp simeof,cpopj,illfn,illfn,0,.+1
exp simeof,cpopj,illfn,nulspo,retzer,cpopj,openfi,cpopj,cpopj
exp showln,notry
wrdtxt: exp getchb,putchb,getlnx,putlnx,logclo,.+1
exp illfn,illfn,putpgx,illfn,illfn,logini,wrdopn,logclo,wrdlts
exp showln,notry
wrdrec: exp getb,putb,illfn,illfn,logclo,.+1
exp getxb,illfn,illfn,illfn,illfn,logini,wrdopn,logclo,cpopj
exp showln,notry
chrtxt: exp getchb,putchb,getlnx,putlnx,logclo,.+1
exp illfn,illfn,putpgx,setpb,curpbx,logini,chropn,logclo,cpopj
exp showln,notry
chrrec: exp getb,putb,illfn,illfn,logclo,.+1
exp getxb,illfn,illfn,setpb,curpbx,logini,chropn,logclo,cpopj
exp showln,notry
rectxt: exp getcx,putcx,getlx,putlx,logclx,.+1
exp illfn,illfn,putpgx,illfn,illfn,loginx,chropx,logclx,cpopj
exp showln,notry
recrec: exp getbxr,putbxr,illfn,illfn,0,.+1
exp illfn,illfn,illfn,setpbx,curpbx,bxini,bxopn,cpopj,cpopj
exp showln,notry
mtarec:
mtatxt: exp notop,notop,notop,notop,0,.+1
exp notop,notop,notop,notop,notop,cpopj,mtaopn,cpopj,cpopj
exp notop,notop
;The following table is used for tty and ttyout. It is set up by pasin.
ttynt: exp gettty,puttty,getlnx,putlnx,0,.+1
exp illfn,illfn,putpgx,illfn,illfn,ttyini,cpopj,cpopj,cpopj
exp ttyshl,ttyfxl
;The following table is used after an error
erropt: exp cpopj,cpopj,cpopj,cpopj,0,.+1
exp cpopj,cpopj,cpopj,cpopj,cpopj,cpopj,cpopj,cpopj,cpopj
exp cpopj,notry
;The following is used for unopened files:
unop.:
unop: exp notop,notop,notop,notop,0,.+1
exp notop,notop,notop,notop,notop,cpopj,cpopj,cpopj,cpopj
exp notop,notop
; Openfi is called by the device-dependent openner, f%open.
; For simple devices, f%open can simply point to openfi.
;openfi just does an openf - pretty straight-forward
; b - fcb, must be saved and restored
; g - openf word
; garbages a,h
openfi: skipe filerr(b) ;no-op if error already seen
popj p,
move h,b ;save fcb pointer
hrrz a,filjfn(h) ;set up args for openf - jfn
move b,g ;openf word
openf
erjrst doope ;[5]
move b,h ;restore fcb
popj p,
oper: move h,b ;error in openfi
doope: movei a,400000 ;current process
geter
hrrz a,b ;error in RH only
smoper: move b,h ;restore fcb - entry if error is known
movem a,filerr(b) ;save error for user
move a,filbad(b) ;set bad fileof
movem a,fileof(b)
movem a,fileol(b)
hrli t,erropt ;and set up to get error if we try more I/O
hrri t,filr11(b)
blt t,filr99(b)
move t,filflg(b)
popj p, ;caller will process error later
errchk: skipn filerr(b) ;error?
jrst erchOK ;no
move t,filflg(b) ;yes - is he enabled?
trne t,fl%ope
jrst erchOK ;yes - then that's OK, too
;here if an error we are supposed to handle
move d,b ;
pushj p,erp ;print error message
move b,d
hrroi a,[asciz /Try another file spec: /]
psout
hlre a,filcnt(b) ;restore state, without filespec
movn a,a ;a has size of component, 0 if text
setzm c,d ;no filespec
tlo c,(op%tty) ;but ask for it from tty
move f,filsvf(b)
tlo f,(gj%cfm) ;confirm it from tty
move g,filsvg(b)
move h,filflg(b)
popj p, ;error return
;here for no error or one we don't care about
erchOK: aos (p)
popj p, ;OK - skip return
;getjfn - AC usage
; b - fcb pointer - must be saved and restored
; c - string
; d - string length
; f - gtjfn word
; h - used to save p or h
; klobbers t,a,c,d,h
;getjfn gets a jfn if necessary. In case of
; error, it sets of filerr, so the user better check!
getjfn: skipe filerr(b) ;should be a no-op if previous error
popj p,
tlne c,(op%wld) ;set up for wild cards if requested
tlo f,(gj%ifg)
tlne c,(op%tty) ;if user asked for spec from tty, get it
jrst ttyspc
jumpn d,havspc ;if ascii spec, use it
skipe filjfn(b) ;otherwise, if jfn already exists, use it
popj p,
;here if no spec and no existing jfn - this is an internal file, we have
;to gensym a name. Also, we set fl%tmp so it gets deleted upon exit of
;the lexical scope in which it was created.
;The name we make is of the form PAS-INTERNAL.001234;T where 1234 is
;the address of the FCB in octal (for debugging)
movei t,fl%tmp ;set temp flag
iorm t,filflg(b)
move h,p ;h _ saved copy of p
hrri p,6(p) ;advance stack to get space for new name
hrri d,1(h) ;place for new spec
hrli d,[ascii /PAS-INTERNAL./]
blt d,3(h) ;put it there
move d,[point 7,3(h),20] ;place to put the rest
hrlz a,b ;use addr of FCB, in octal
movei c,6 ;6 digits
setz t,
makspl: lshc t,3 ;shift t and a - bytes in t
addi t,"0" ;convert to char
idpb t,d ;and put in destin
setz t,
sojg c,makspl ;loop for 6 char's
movei t,";" ;now put ;T
idpb t,d
movei t,"T"
idpb t,d
setz t,
idpb t,d
move t,b ;where makspx expects B to be saved
makspr: move a,f ;a _ flags
hrroi b,1(h) ;b _ ptr to stack copy
gtjfn
erjrst makspe ;[5]
jrst makspx ;finished making spec
;If this is an internal file, we want to be able to read or update it
;even if it doesn't exist. So, if the OLD bit is on, we will clear it
;(and set the WRITE bit for openf), and try again. If that doesn't
;help, there is something more serious wrong.
makspe: tlnn f,(gj%old) ;did he ask for old file?
jrst specer ;no - nothing we can do
tlz f,(gj%old) ;yes - enable for writing
tro g,of%wr ;also openf bits
jrst makspr ;retry this way
;here if the user gave us a spec.
havspc: movei t,fl%tmp ;[37] a new file spec - clear temp from old one
andcam t,filflg(b)
move t,b ;t _ saved copy of b
ifn klcpu,< ;[5]
hrli a,440700 ;a _ ptr to start of copy in stack
hrri a,1(p)
adjbp d,a ;d _ ptr to last byte stack copy
> ;[5] ifn klcpu
ife klcpu,< ;[5] start
hrri a,1(p) ;RH(a) _ point to start on stack
push p,e
idivi d,5 ;d _ words, e _ bytes
addi d,(a) ;RH(d) _ addr of last byte
hll d,byttab(e) ;LH(d) _ pointer to last byte
pop p,e
> ;[5] end ife klcpu
move h,p ;h _ saved copy of p
hrri p,1(d) ;advance stack to cover whole copy
hrl a,c ;a _ blt from original to stack
blt a,1(d)
setz a, ;make asciz by putting null at end
idpb a,d
move a,f ;a _ flags
hrroi b,1(h) ;b _ ptr to stack copy
gtjfn
erjrst specer ;[5]
makspx: move b,t ;restore ac's
move p,h
movem a,filjfn(b) ;return new jfn
popj p,
ifn tenex,< ;[5]
byttab: point 7,0 ;[5]
point 7,0,6 ;[5]
point 7,0,13 ;[5]
point 7,0,20 ;[5]
point 7,0,27 ;[5]
> ;[5] ifn tenex
specer: move a,t ;get error recovery flag
move a,filflg(a)
trne a,fl%ope ;if he wants to handle errors,
jrst [move b,t ;let him - first restore AC's
move p,h
jrst oper]
;special error printer needed for this routine, because main one
;uses jfns, but we don't have a file spec yet
;note that we are still in a funny context, where p and b are odd
movei a,[asciz / /]
esout
movei a,.priou
hrloi b,400000
setz c,
erstr
jfcl
jfcl
hrroi a,[asciz / - /]
psout
hrroi a,1(h) ;file spec the user gave
psout
hrroi a,[asciz /
Try another file spec: /]
psout
move b,t ;restore to standard AC's
move p,h
tlo f,(gj%cfm) ;confirm spec from tty
;jrst ttyspc ;and get spec from tty
ttyspc: move h,b ;h _ saved copy of b
movei a,fl%tmp ;clear temp flag, as this is new spec
andcam a,filflg(b)
ttyspl: move a,f ;a _ flags
tlo a,(gj%fns)
move b,[xwd .priin,.priou]
gtjfn
erjrst ttyspe ;[5]
move b,h
movem a,filjfn(b) ;return new jfn
popj p,
ttyspe: movei a,[asciz / /]
esout
movei a,.priou
hrloi b,400000
setz c,
erstr
jfcl
jfcl
hrroi a,[asciz /
Try another file spec: /]
psout
jrst ttyspl
subttl global entries to I/O routines
;In order to use the routines in PASNUM, get and put must obey the
;following AC usage conventions:
; t,a - temps
; b up - must be preserved
get.: jrst @filget(b) ;get is odd because it is also a jsys
getch==get.
put: jrst @filput(b)
putch==put
getln: jrst @filgln(b)
putln: jrst @filpln(b)
putpg: vcall f%putp
setpos: vcall f%setp
curpos: vcall f%curp
getx.: vcall f%getx
putx: vcall f%putx
retzer: setzm 1(p) ;returns zero - used for device nul
popj p,
;setpos for nul:. no-op, except in read mode if GET not suppressed,
;it simulates EOF.
nulspo: jumpn d,nulspx ;if get suppression, no-op
skprea ;if write mode, no-op
nulspx: popj p, ;no-op
jrst simeof ;else simulate GET
resdev: movsi c,(cz%abt!co%nrj) ;this is DISMISS - the tops10 resdv.
jrst clochk
relf.: tlza c,(co%nrj) ;this is RCLOSE - release the jfn
clofil: tlo c,(co%nrj) ;this is CLOSE - keep the jfn
clochk: move a,filtst(b) ;if the file isn't init'ed
caie a,314157
pushj p,initb. ;then do it
doclos: ;We now assume that if there is a non-zero jfn, that is a
;valid jfn. SETPRM is thus coded to defend against garbage
;jfn's. But if a user calls this, he should beware.
;warning: only a and t are free. Be sure the filclo routine knows that
;c - close bits
movei a,0 ;do mode-dependent clean-up
exch a,filclo(b)
skipe a ; if 0, no routine
pushj p,(a)
move t,filjfn(b) ;close file
jumpe t,clofb ;if no jfn, nothing to close
;if we are killing the jfn, special cleanups may be needed
tlne c,(co%nrj) ;if asked to kill the jfn, do so
jrst clonk ;don't kill jfn
;beginning of special cleanups for releasing jfn
setzm filjfn(b) ;clear all record of it
move a,filflg(b) ;get flags
trnn a,fl%tmp ;if temp file
jrst clonk ; not temp, done with it
;Now, all cases go either to the following code for temp files,
;or to clonk, for closing without killing.
;temp file - releasing implies deleting
hrrz a,t ;delete instead of just closing
hrli a,(co%nrj) ;first we must close it
closf
chkquo
erjrst clorl ;couldn't close it - just release it
hrli a,(df%exp) ;now delete, expunge, and release it
delf
erjrst clorl ;couldn't - just release it
jrst clofb ;done with this jfn
;normal file - close it without killing it, using bits from c
clonk: hrrz a,t
hll a,c
closf
chkquo ;[27]
erjrst .+2 ;[7] close failed, release instead
jrst clofb ; close worked, go on
tlne c,(co%nrj) ;don't release if asked not to!
jrst clofb
hrrz a,t
clorl: rljfn
chkquo ;[27]
erjrst clofb ;[7] release failed too, no hope
;All cases join here, even after "impossible" combinations of errors
clofb: movei a,0 ;clean up buffers if any
exch a,filbuf(b)
jumpe a,clof2 ; none- done
push p,b ;demap the page
push p,a ; since may have been doing pmap I/O on it
ife tenex,<
hlrz c,a ;count in rh of c
ldb b,[point 9,a,26] ;page no.
hrli b,400000 ;in this process
seto a, ;clear the page
hrli c,(pm%cnt) ;do all at once
pmap
chkquo ;[27]
erjmp .+1 ;no errors here, please
> ;ife tenex
ifn tenex,<
hlrz t,a ;count of pages to be released
ldb b,[point 9,a,26] ;page no.
hrli b,400000 ;in this process
seto a, ;clear the page
setz c,
clof1l: pmap
addi b,1 ;next page
sojg t,clof1l ;if any
> ;ifn tenex
pop p,a ;restore target page
pushj p,relpg. ;put it in free list
pop p,b
clof2: hrli t,unop ;[12] now mark file as no longer open
hrri t,filr11(b) ;[12] so future accesses get error
blt t,filr99(b) ;[12]
popj p,
break: vcall f%brk ;force out buffers
breaki: push p,c
push p,b
move a,[ascii /-----/] ;old line no. no longer valid
movem a,fillnr(b)
pcall f%init ;use buffer filler if any
pop p,b
pop p,d
hlre c,filcnt(b) ;make up argument for binary get
movn c,c ;is negative count in filcnt
skpwrt ;don't do get if write-only file!
jumpe d,@filget(b) ;and get unless suppressed
move a,filcnt(b) ;otherwise clear buffer
setzm (a)
aobjn a,.-1
move a,filbad(b) ;and set eoln, since dummy data in buf
movem a,fileol(b)
popj p,
nextfi: movsi c,(co%nrj) ;go to next wildcard file - must be closed
pushj p,doclos
move a,filjfn(b)
gnjfn
jrst nonext
movem a,1(p) ;if succeed, return flags (always nonzero)
popj p,
nonext: move d,b
movei a,400000 ;nextfi failed, see why
geter
andi b,-1 ;get error code only
caie b,gnjfx1 ;if anything except ran out of files
jrst nonxt1 ;it is a real error
move b,d
setzm 1(p) ;bad return
setzm filjfn(b) ;they released our jfn (naughty folks)
popj p,
nonxt1: pushj p,ioer ;a real error
setzm 1(p) ;still give bad return
popj p,
subttl device-independent routines for error recovery
;showln - this is the default showln for devices where we can't
; really show the current line.
showln: push p,a
push p,c
push p,d
hrroi a,[asciz /[Error at character number /]
psout
pushj p,curpos ;get current position
push p,b
movei a,.priou
move b,1(p) ;returned value
movei c,12 ;in decimal
nout
jfcl
hrroi a,[asciz /]
/]
psout
pop p,b
pop p,d
pop p,c
pop p,a
popj p,
;notry - use this routine for FIXLIN with devices where you don't
; implement retrying.
notry: hrroi a,[asciz /Call to READ/]
psout
pushj p,runer.
hrroi a,[asciz /
[Skipping bad character]
/]
psout
jrst @filget(b)
;tryagn - ask him to try again. If there is a debugger, offer to
; go to it.
;t - PC to print if error; A - jfn for printing; B - FCB
tryagn: push p,t
push p,a
push p,b
push p,c
tryag1:
;Now, if DDT is there, do a bit differently
skipe .jbddt ;.jbddt?
jrst tryddt ;yes - that is fine
move a,[xwd 400000,770] ;else look for VMDDT
rpacs ;page exist?
move a,-2(p)
tlnn b,(pa%pex) ;
jrst trynod ;no - continue
tlnn b,(pa%ex) ;allowed to execute?
jrst trynod ;no - continue
;Here if DDT - give him an option
tryddt: move a,-2(p)
hrroi b,[asciz /
[Try again, from the beginning of the bad number.]
[Or type D to enter the debugger.]
/]
setz c,
sout
move b,-1(p) ;get back FCB
pushj p,@filget(b)
move a,filcmp(b) ;See if he typed a D
caie a,"D"
cain a,"d"
caia
jrst tryOK ;no a D - use what he gave us
;Here if he wants DDT - let runer. do it
move t,-3(p) ;PC passed to us in T
hrroi a,[asciz /Call to READ /]
psout
pushj p,runer.
pcall f%init ;clear input buffer again
jrst tryag1
;Here for no DDT cases
trynod: move a,-2(p)
hrroi b,[asciz /
[Try again, from the beginning of the bad number.]
/]
setz c,
sout
move b,-1(p)
pushj p,@filget(b) ;just get a char
tryOK: pop p,c
pop p,b ;return it to the user
pop p,a
pop p,t
popj p,
subttl pmap I/O - ascii top-level routines
filadv==fils11 ;routine to get to next buffer
filpag==filst1 ;disk page currently working on
filbgp==filst4 ;disk page at beginning of buffer
filpgb==fils15 ;number of pages in buffer
filbct==filst2 ;bytes in current page
filbpt==filst3 ;pointer to next byte in buffer
fillby==fils12 ;last byte in file
filcby==fils13 ;current byte in file
filbfp==fils16 ;ptr to beginning of current page
filbfs==fils17 ;size of page in bytes
fillct==fils20 ;count of last record operation
;put
putchd: aos a,filcby(b) ;advance current byte
camle a,fillby(b) ;beyond end seen so far?
movem a,fillby(b) ;yes - update it
sosge filbct(b) ;room in buffer?
pushj p,@filadv(b) ;no - next
move a,filcmp(b) ;put it in
idpb a,filbpt(b)
ercal maperr
popj p,
noput: move d,b ;error routine if not open for write
movei a,iox2 ;write priv req
movem a,filerr(d)
jrst erp.
;This routine is called when we get an error upon attempting access
; to a page. It makes assumes that the caller uses the following
; sequence:
; aos filcby(b)
; sos filbct(b)
; idpb a,filbpt(b)
; ercal maperr
; as it will undo the sideeffects of these operations if necessary.
; When a hole is found, we just have to set a to zero after clearing
; the page.
; But on a real error, we have to back out all the operations shown
; and abort the caller.
maperr:
;for tops-20 the most likely thing here is that we tried to read a
; hole in the file. Tops-20 gives an ill mem read in that case.
;Also, it may be quota exceeded.
;So the code comes in these pieces:
; diagnose it - hole in the file?
; if a hole, then give a zero page
; else, print an error message and back out of the I/O operation
ife tenex,<
push p,b ;see if page exists
;First see if we have a quota problem
push p,a
repeat 1,< ;This is due to a monitor bug.
move a,[point 7,a] ;do an ILDB to clear first part done
ildb a,a ;since ERCAL may leave it set
> ;repeat 1
movei a,400000 ;see what error
geter
tlz b,777777 ;b _ error code
cain b,iox11 ;if quota error
jrst mapquo ;special handling
pop p,a
;here we check to see if the page is perhaps nonexistent in the file
;if so, we treat it as zeros.
move b,0(p) ;[35] get back FCB
hrrz a,filbpt(b) ;addr of core page
lsh a,-11 ;convert to page
hrli a,.fhslf ;in out fork
rpacs
erjmp maper3 ;treat this as an I/O error
;The case we are looking for is read-only access and an indirect pointer
tlnn b,(pa%wt) ;if have write access, not this problem
tlnn b,(pa%ind) ;if indirect too, that is it
jrst maper3 ;write access or not indirect: normal error
;here if it is a hole. clear the page
maper1: move b,a ;b _ .fhslf,,core page no.
seto a, ;clear page
push p,c
setz c, ;no counts
pmap
chkquo ;[27]
erjmp maper2 ;can't clear page
pop p,c
pop p,b
setz a, ;return zero byte
popj p,
;here if is a quota error, to retry
mapquo: push p,c
;error message
hrroi a,[asciz / Quota exceeded or disk full at /]
esout
movei a,.priou
sos -3(p) ;adjust ret addr to go back to idpb
sos -3(p)
hrrz b,-3(p)
movei c,10 ;base 8
nout
jfcl ;not sure how to handle errors here
hrroi a,[asciz /
[Find some space, then type CONTINUE]
/]
psout
; Finally we are ready to restore to the user's context and continue,
; if user types CONTINUE
pop p,c
pop p,a
pop p,b
haltf ;let him delete some files
adjstk p,-1 ;go retry
jrstf @1(p) ;must use jrstf to restore first part done
ife klcpu,<printx Using KL instruction (ADJBP) at QUOBPT+>
;If you want to use a non-KL DEC-20, you will have to write a routine to
;simulate adjbp. It must be able to handle any byte size.
;here is the beginning of the true error code.
maper2: pop p,c
maper3: pop p,b
> ;ife tenex
sos filcby(b) ;move back
aos filbct(b)
ifn klcpu,< ;[5]
movni a,1
adjbp a,filbpt(b)
movem a,filbpt(b)
> ;[5] ifn klcpu
ife klcpu,< ;[5] start
;****** Tenex hackers, note: this code assume byte size = 7, not always true.
sos filbpt(b)
repeat 4,<ibp filbpt(b)>
> ;[5] end ife klcpu
pop p,(p) ;abort caller
jrst ioerp
;get
getchd: aos a,filcby(b) ;advance current byte
camg a,fillby(b) ;beyond eof?
jrst getcd1 ;no - do normal input
dskeof: sos filcby(b) ;yes - don't do the advance
;jrst simeof
;simeof - simulate eof for pmap, texti (etc.?)
simeof: move t,filbad(b) ;yes - set eof
movem t,fileof(b)
movem t,fileol(b)
skipl filcnt(b) ;if ascii
setzm filcmp(b) ;clear buffer, for read/ln
movei t,iox4 ;simulate monitor eof error code
movem t,filerr(b)
popj p,
getcd1: sosge filbct(b) ;count bytes left in this buffer
pushj p,@filadv(b) ;none - get new buffer
ildb a,filbpt(b) ;get character
ercal maperr
move t,fillts(b) ;line no. test bit if 7 bit mode
tdne t,@filbpt(b) ;was it a line no.?
jrst getcln ; yes
andi a,177 ; no - be sure legal ascii
jumpe a,getchd ;ignore nulls
move a,@filcht(b) ;get eoln flag and mapped char
hlrem a,fileol(b) ;put down eoln flag
hrrzm a,filcmp(b) ;put down mapped char
came a,[xwd -1," "] ;carriage return in official mode
popj p,
geteol: pushj p,@filget(b) ;we have a CR, look for real EOL
skipe fileof(b) ;stop after errors
popj p,
skipg fileol(b) ;real EOL?
jrst geteol ;no, next char
popj p, ;yes, done
define letter,<exp .-beg> ;real letter
define lc,<exp .-beg-40> ;upper case equiv. of lower case letter
define linech(x),<xwd x,.-beg> ;end of line char
norcht:
beg==norcht
repeat 12,<letter> ;0 - 11
linech 1 ;12
letter ;13
linech 1 ;14
linech -1 ;15
repeat 14,<letter> ;16 - 31
linech 1 ;32
linech 1 ;33
repeat 3,<letter> ;34 - 36
ifn tenex,<linech 1> ;37
ife tenex,<letter> ;37
repeat 162,<letter> ;everything else is a letter
lccht:
beg==lccht
repeat 12,<letter>
linech 1
letter
linech 1
linech -1
repeat 14,<letter>
linech 1
linech 1 ;33
repeat 3,<letter> ;34 - 36
ifn tenex,<linech 1> ;37
ife tenex,<letter> ;37
repeat 101,<letter> ;40 - 140
repeat 32,<lc> ;141 - 172
repeat 5,<letter> ;173 - 177
;
;Now the tables for standard pascal semantics - replace EOLN by space
;
define linech(x),<xwd x," "> ;end of line char
;otherwise the tables are the same
norchx:
beg==norchx
repeat 12,<letter> ;0 - 11
linech 1 ;12
letter ;13
linech 1 ;14
linech -1 ;15
repeat 14,<letter> ;16 - 31
linech 1 ;32
linech 1 ;33
repeat 3,<letter> ;34 - 36
ifn tenex,<linech 1> ;37
ife tenex,<letter> ;37
repeat 162,<letter> ;everything else is a letter
lcchx:
beg==lcchx
repeat 12,<letter>
linech 1
letter
linech 1
linech -1
repeat 14,<letter>
linech 1
linech 1 ;33
repeat 3,<letter> ;34 - 36
ifn tenex,<linech 1> ;37
ife tenex,<letter> ;37
repeat 101,<letter> ;40 - 140
repeat 32,<lc> ;141 - 172
repeat 5,<letter> ;173 - 177
;called by get to skip line no.
getcln: move t,@filbpt(b) ;line no. - get it
movem t,fillnr(b) ;save it for user
aos filbpt(b) ;skip it
movei t,5 ;update currentposition
addm t,filcby(b)
movni t,5 ;note getchb already skipped one char, so
addb t,filbct(b) ; we only skip 5
jumpge t,getchd ;now get real character
;the context in which filadv is valid is where we have just done sosge filbct,
;and are about to do ildb. Usually this is right, as in the subtraction of
;5 above, 1 of the 5 is in the new block. so that is the sosge. we will
;still have to do an ibp afterwards, though. If we are further into the
;word than the first char, we now back up, since filadv will leave us at
;the start of the buffer (and its error handling is predicated on the
;assumption that we are working on the first char)
addi t,1 ;if more than one char into new buffer
addm t,filcby(b) ;move back (T is negative)
pushj p,@filadv(b) ;go to new buffer
ibp filbpt(b) ;pass over first char (tab)
jrst getchd ;now go back for real char
subttl pmap I/O - buffer advance and go to new page
;dskadv - get to the next page when reading sequentially. If
; the getpage succeeds, this gives new byte ptr, count, etc., for
; the new page. Otherwise you are left exactly where you were before,
; with filcby adjusted, since the caller is assumed to have
; incremented it.
; t,a - temps
; b up - preserved
dskadv: move t,filpag(b) ;old page
addi t,1 ;new page
pushj p,getfpg ;get page routine
jrst badadv ;can't get new page
move t,filbfs(b) ;bytes in buffer
subi t,1 ;caller has done sosge
movem t,filbct(b)
move t,filbfp(b) ;pointer to start of buffer
movem t,filbpt(b)
popj p,
badadv: sos filcby(b) ;user has done aos on this
pop p,(p) ;abort our caller
popj p,
;getfpg - get specified page
; t - desired page - preserved
; a - temp
; b up - preserved
; returns: t - requested disk page
; also resets
; filbfp(RH) to point to the core page where the disk page is mapped
; filpag to indicate we are on a new file page
; filbgp if we have to remap the buffer, to indicate new beginning
; the user is assumed to adjust counts, pointers, etc., as he likes
getfpg: move a,t ;a _ desired page
sub a,filbgp(b) ;a _ pages beyond start of buffer
cail a,0 ;if before buffer start
caml a,filpgb(b) ;or after buffer end
jrst getfpn ;need new pages
;here when desired page is in buffer
push p,c
hrrz c,filbuf(b) ;beginning of core buffer
lsh a,11 ;convert page offset to word offset
add a,c ;a _ core addr where we have file page
hrrm a,filbfp(b) ;save as current buffer start
movem t,filpag(b) ;also remember we are now where asked
pop p,c
jrst cpopj1
;here when desired page is not in buffer
getfpn: push p,c ;filadv routine for pmap I/O
push p,b
hrr a,t ;desired page
hrl a,filjfn(b) ;on this file
ife tenex,<
hlr c,filbuf(b) ;c _ page count for buffer
hrli c,(pm%cnt!pm%rd!pm%wr!pm%pld) ;say we have a count, preload
hrrz b,filbuf(b) ;address of buffer
lsh b,-9 ;make page no.
hrli b,400000 ;current process
pmap
chkquo ;[27]
erjmp badpag
> ;ife tenex
ifn tenex,<
push p,d ;d will be page count
hlrz d,filbuf(b)
movsi c,(pm%rd!pm%wr)
hrrz b,filbuf(b) ;addr of buffer
lsh b,-9 ;convert to page
hrli b,400000 ;this process
getfpl: pmap ;one page only
addi a,1 ;go to next page
addi b,1
sojg d,getfpl ;and do it if desired
pop p,d
> ;ifn tenex
;general success return
gotpag: pop p,b
pop p,c
movem t,filpag(b) ;only now can we say are on that page
movem t,filbgp(b) ;and that page is buffer begin
hrrz a,filbuf(b)
hrrm a,filbfp(b) ;and current page is first in buffer
cpopj1: aos (p) ;skip return - success
popj p,
;note that badpag is called with b&c saved on stack
badpag: pop p,b ;we don't change filpag, as haven't moved
pop p,c
jrst ioerp ;gives non-skip (error) return
subttl pmap I/O - actual I/O routines for record files
;The following routines set up C to indicate the desired
; transfer, and then call getdlp or putdlp, which simulate
; sin and sout. If an I/O error occurs, getdlp or putdlp
; will return with c as at the point of error. Thus the
; caller may have some adjustments to do.
;get
getd: movem c,fillct(b) ;assume no. transferred = no. requested
movn c,c ;make up aobjn word
hrl c,c ;lh(c) _ no. to transfer
hrri c,filcmp(b) ;rh(c) _ starting loc to transfer
pushj p,getdlp ;sin
hlre c,c ;c _ - no. left untransferred
addm c,fillct(b) ;adjust assumption
popj p,
;put
putd: movem c,fillct(b)
movn c,c
hrl c,c
hrri c,filcmp(b)
pushj p,putdlp ;sout
hlre c,c
addm c,fillct(b)
popj p,
;getx
getxd: move d,c ;requested upper limit
sub c,fillct(b) ;c _ no. needed this time
movn c,c ;make aobjn word
hrl c,c
hrri c,filcmp(b)
add c,fillct(b) ;adjust by no. already done
pushj p,getdlp ;sin
hlre c,c
addm c,fillct(b)
popj p,
;putx
putxd: move c,filcby(b) ;go back to beginning of record
sub c,fillct(b) ;c _ byte at beginning
pushj p,dskmov ;move to beginning of record
popj p, ;no - I/O error in setpos
move c,fillct(b) ;get back no. to transfer
jrst putd ;now put out the record
;Here are the sin/sout simulations. Note that if there is
; an I/O error, filadv will sos filcby(b) and abort the routine.
; In that case c will be left negative, and the caller (above)
; will do the right thing.
;sin
getdlp: aos a,filcby(b) ;assume we are going to a new byte
camle a,fillby(b) ;beyond eof?
jrst dskeof ;simulate eof
sosge filbct(b) ;anything left in buffer?
pushj p,@filadv(b) ;no - next buffer - may abort here
ildb a,filbpt(b)
ercal maperr
movem a,(c)
aobjn c,getdlp
popj p,
;sout
putdlp: aos a,filcby(b) ;assume we are going to a new byte
camle a,fillby(b) ;beyond eof?
movem a,fillby(b) ;update eof
sosge filbct(b)
pushj p,@filadv(b)
move a,(c)
idpb a,filbpt(b)
ercal maperr
aobjn c,putdlp
popj p,
subttl pmap I/O - device dependent openning
;main entry to do openfi
dskopn: skipe filerr(b) ;must be no-op if error in jfn
popj p,
movei t,dskadv ;disk advance routine
movem t,filadv(b)
ldb t,[point 6,g,5] ;get byte size
move a,t ;a _ byte size
lsh t,^D24 ;put in byte size position
movem t,filbpt(b) ;in pointer
tlo t,440000 ;byte pointer LH
hllm t,filbfp(b) ;RH set up later (may be already)
movei t,^D36 ;compute no. of bytes in a page
idiv t,a ;t _ no. of bytes/word
lsh t,9 ;t _ no. of bytes/page
movem t,filbfs(b) ;save as public knowledge
;here we have to split according to the sort of open being done
trne g,of%app ;special code to simulate append
jrst dskapp
trnn g,of%rd ;special code if write-only
jrst dskwrt
;read or update - must be able to read, so pmap always works
trne g,of%wr ;if only read
jrst dskop1 ; not - ignore this
;read only
movei t,noput ;disable writing
movem t,filput(b)
movei t,dskrcl ;use special close (doesn't change size)
movem t,filclo(b)
;read or update again
dskop1: pushj p,openfi
skipe filerr(b) ;this may fail
popj p,
pushj p,sizefi ;set up end of file stuff
jrst dskini
;write only
dskwrt: pushj p,openfi
skipe filerr(b)
popj p,
hrrz a,filjfn(b) ;see if we can read, too
move h,b
gtsts
erjmp doope
tlnn b,(gs%rdf)
jrst dskbn1 ;can't read it, use normal binary mode
move b,h
setzm fillby(b) ;file is now zero length
jrst dskini
;here to exit to normal binary routines in case can't use pmap. DEC
;requires read priv's to do pmap, although tenex doesn't
dskbn1: move b,h
hrr a,filjfn(b) ;It's open - close it
hrli a,(co%nrj)
closf
erjrst oper ;[7]
dskbin: hrli t,chrtxt ;change to normal mode
skipge filcnt(b)
hrli t,chrrec
hrri t,filr11(b)
blt t,filr99(b)
jrst chropn ;now open in real mode
;append simulation
dskapp: trc g,of%app!of%rd!of%wr
pushj p,dopenf ;try read/write open
jrst appbin ;failed, so try real append
pushj p,sizefi ;find end of file
skipe filerr(b) ;it can fail
popj p,
pushj p,dskini
move c,fillby(b) ;go to end
setz d, ;suppress get
jrst dskspo
;here to ext to normal binary routines in case can't append using pmap
appbin: trc g,of%app!of%rd!of%wr
jrst dskbin
;here to do openf for dskapp - needs special routine so we don't
; trigger error processing if it fails.
dopenf: move h,b ;save b
hrrz a,filjfn(h)
move b,g
openf
erjrst cpopjh ;[5]
aos (p) ;good return
cpopjh: move b,h ;bad return
popj p,
;These are common initializations that must not be done until
;we know the open succeeded
dskini: setzm filbct(b)
setom filpag(b)
movni t,377777 ;force us to get new page
movem t,filbgp(b)
setzm filcby(b)
ldb a,[fl%buf!filflg(b)] ;number of buffers user wants
caig a,0 ;must be between 1 and 36
movei a,mapbfs ;if 0, use default
caile a,^D36 ;if too big, use maximum
movei a,^D36
movem a,filpgb(b) ;save as buffer size in pages
pushj p,alcbuf ;# pages is arg to alcbuf, in A
move t,filbuf(b)
hrrm t,filbfp(b) ;LH was set up at beginning
popj p,
;alcbuf - allocation a page as a buffer - used elsewhere, too
; a - number of pages to allocate
alcbuf: hlrz t,filbuf(b) ;any buffer already?
jumpe t,alcbfn ;no, get a new one
camn t,a ;yes, right size?
popj p, ;yes, nothing to do
push p,a
move a,filbuf(b) ;no, throw it away
pushj p,relpg.
pop p,a
alcbfn: pushj p,getpg. ;get a new buffer
movem a,filbuf(b) ;store size,,addr
popj p,
ife srisw,< ;[23]
;Here is the normal code for turning on the line number test.
;It turns it on for all text files with byte size 7. If there
;are no line numbers in the file, of course everything is fine.
;This routine is considered device-dependent, since it is called only
;for devices capable of having line numbers. For other devices, the
;test is simply CPOPJ, which leaves the test bit (FILLTS) 0. This
;disables the test. This distinction is just for safety, though
;presumably such devices wouldn't have line numbers anyway.
wrdlts:
dsklts: ldb t,[point 6,filbfp(b),11] ;get byte size
caie t,7 ;if not 7
popj p, ;can't be line numbered
aos fillts(b) ;is line number - set fillts
popj p,
> ;[23] ife srisw
ifn srisw,< ;[23]
;This code is because SRI's EMACS puts random low-order bits into
;files. Thus we have to test the first word of the file to see if
;it is a line number, and turn off testing if not.
;xxxlts - device-dependent routine to see if this is a line-numbered
; file. Only devices that read full words have such a routine. Others
; use CPOPJ, which results in fillts still being zero for them. Error
; processing is a big pain in the neck, since we really want to save
; eof and errors for the first real read. So we generally have to
; bypass the normal I/O routines. These routines depend upon the fact
; that a line numbered file must begin with a line number. We have to
; enforce this since EMACS tends to create things that look like line
; numbers by setting the low order bit randomly throughout the file.
dsklts: movei t,0 ;get page 0 of file
skiple fillby(b) ;[17] if file is zero size, not numbered
pushj p,getfpg
popj p, ;if can't get page 0,not numbered
setom filpag(b) ;pretend we didn't read the page
move a,filbfp(b) ;get addr of first word
move t,(a) ;get first word
erjmp cpopj ;if error, not linenumbered
;comlts - entry for testing line number. first byte of file in t
comlts: ldb a,[point 6,filbfp(b),11] ;get byte size
trze t,1 ;if low order bit off or
caie a,7 ;if not 7
popj p, ;can't be line numbered
camn t,[ascii / /] ;this is a page mark
jrst isnum ;which is OK to start the file
movei a,5 ;otherwise must be digits
move c,[point 7,t] ;get from t
comlt1: ildb d,c ;next digit
cail d,"0" ;if not digit
caile d,"9"
popj p, ;isn't a line number
sojg a,comlt1 ;go back for next
isnum: aos fillts(b) ;is line number - set fillts
popj p,
> ;[23] ifn srisw
subttl pmap I/O - device-dependent routines
;break
dskbrk: skipge filbgp(b) ;break function - force out buffer
popj p,
move a,filbuf(b) ;count,,buf addr
move d,b ;save fcb
ife tenex,<
hlrz c,a ;count in rh of c
ldb b,[point 9,a,26] ;page no.
hrli b,400000 ;in this process
seto a, ;clear the page
hrli c,(pm%cnt) ;do all at once
pmap
chkquo ;[27]
erjmp ioer ;no errors here, please
> ;ife tenex
ifn tenex,<
hlrz t,a ;count of pages to be released
ldb b,[point 9,a,26] ;page no.
hrli b,400000 ;in this process
seto a, ;clear the page
setz c,
dskbrl: pmap
addi b,1 ;next page
sojg t,dskbrl ;if any
> ;ifn tenex
move b,d
popj p,
;close for read-only modes
dskrcl: push p,c ;special close that doesn't change size
push p,d
jrst dskcl1
;breakin
dskbri: setzm filbct(b) ;breakin function - clear buffer
setom filpag(b)
movni t,377777 ;force us to get new page
movem t,filbgp(b)
setzm filcby(b)
setzm fillct(b)
popj p,
;close for read/write modes
dskclo: push p,c
push p,d ;filclo allows only t and a free
push p,b ;now we will reset the eof pointer
ifn tenex,<hrli a,.fbbyv> ;the offset - byte size
ife tenex,<hrli a,400000!.fbbyv> ;same, suppress updating disk copy
hrr a,filjfn(b)
move c,filbpt(b)
hrlzi b,007700 ;mask
chfdb
erjmp .+1 ;if not open for output, ignore
move b,(p) ;restore b
hrli a,.fbsiz ;no. of bytes
hrr a,filjfn(b)
move c,fillby(b)
seto b, ;all bits
chfdb
erjmp .+1
pop p,b
dskcl1: pushj p,dskbrk ;close - force last buffer
pop p,d
pop p,c
popj p,
;This doesn't belong here, is called by open
sizefi: move h,b ;compute last byte no.
hrrz a,filjfn(h)
move b,[xwd 2,.fbbyv]
movei c,b ;put b _ byte size, c _ bytes in file
gtfdb ;get from fdb
erjmp doope
ldb t,[point 6,filbpt(h),11] ;t _ our byte size
ldb a,[point 6,b,11] ;a _ file's byte size
cain a,0 ;[2] if zero
movei a,^D36 ;[2] use 36 to prevent divide by 0
camn a,t
jrst sambsz ;if same, use exact calculation
subi c,1 ;else do in words
push p,e ;resetf needs e preserved
movei d,^D36
idiv d,a ;d _ file bytes/wd
idiv c,d ;c _ file words - 1
addi c,1
movei d,^D36
idiv d,t ;d _ our bytes/wd
imul c,d ;c _ our no. of bytes
pop p,e
sambsz: movem c,fillby(h)
move b,h
popj p,
subttl pmap I/O - random access
;setpos
dskspo: move e,d ;e _ suppress get flag
pushj p,dskmov ;go where asked to
popj p, ;error return
posdon: setzm fillct(b) ;old transfers now irrelevant
skipe a,filerr(b) ;clear eof unless due to real error
cain a,iox4
jrst .+2 ;if no error or eof, clear eof
jrst posnoc ; other error, don't clear
move t,filbad(b)
trc t,1
movem t,fileof(b) ;clear pascal eof
setzm filerr(b) ;and error code
posnoc: hlre c,filcnt(b) ;set up arg for binary get if needed
movn c,c
skpwrt ;don't read if open for write
jumpe e,@filget(b) ;get 1st char unless suppressed
move a,filcnt(b) ;new at new place
setzm (a)
aobjn a,.-1
move a,filbad(b) ;1 if input, 0 if not
movem a,fileol(b) ;dummy eol since nothing there
popj p,
;dskmov - internal routine to move to new place
dskmov: caige c,0 ;if less than zero
move c,fillby(b) ;use end of file
push p,c ;save desired byte
idiv c,filbfs(b) ;c _ pages, d _ bytes off in page
move t,c ;req. page goes in t
pushj p,getfpg ;go to that page
jrst dskspf ;failed - leave things unchanged
pop p,filcby(b) ;we are now at requested place
move a,filbfs(b) ;compute bytes left in page
sub a,d
movem a,filbct(b) ;and leave in counter
ife klcpu,< ;[5] start
movei t,^D36
ldb a,[point 6,filbfp(b),11] ;byte size
idiv t,a ;t _ byte / wd
move c,d
idiv c,t ;c _ words, d _ bytes
add c,filbfp(b) ;c _ pointer adjusted by words
jumpe d,.+3 ;loop to adjust c by bytes
ibp c
sojg d,.-1
movem c,filbpt(b) ;store as current byte
> ;ife klcpu
ifn klcpu,< ;[5] end
adjbp d,filbfp(b) ;get pointer to the requested place
movem d,filbpt(b)
> ;ifn klcpu
aos (p) ;good (skip) return
popj p,
dskspf: pop p,(p) ;fail return, restore stack
popj p,
dskcpo: move a,filcby(b)
movem a,1(p) ;just return current byte pt.
popj p,
subttl actual I/O routines for text files on ascii devices
;getchx is the normal ascii input routine
getchx: setzm fileol(b)
hrrz a,filjfn(b)
push p,b
getcx1: bin
erjmp ioerb
jumpe b,getcx1 ;ignore nulls
pop p,a
exch b,a ;a _ char, b _ fdb
getchr: andi a,177
move a,@filcht(b)
hlrem a,fileol(b)
hrrzm a,filcmp(b)
came a,[xwd -1," "] ;if CR in standard Pascal mode
popj p,
jrst geteol ;then search for real EOL
;putchx is the normal ascii output
putchx: hrrz a,filjfn(b)
push p,b
move b,filcmp(b)
bout
chkquo
erjmp ioerb
pop p,b
popj p,
ioerbc: pop p,c
ioerb: pop p,b
jrst ioerp
subttl I/O routines for tty and ttyoutput
filttb==filst1 ;buffer for tty input
;note that this is a variable because it has to be reset during
; interrupt handling
gettty: sosge filbct(b) ;type ahead left?
pushj p,ttyadv ; no - get more
ildb a,filbpt(b) ;get next char
jumpe a,gettty ;ignore null
jrst getchr ;standard ascii processor
ttyadv: hrro a,filttb(b) ;get a new buffer
push p,b
push p,c
ifn tenex,< ;[5]
move b,[exp ttybsz] ;[5] count
ifn sumex,<
movei c,12 ;[7] break on LF
pstin ;[5] pstin; [14] SUMEX/IMSSS only!
ldb t,a ;[7] get terminator
caie t,15 ;[7] cr?
jrst ttyadn ;[7] no, normal
movei t,12 ;[7] yes, add lf
idpb t,a ;[7]
subi b,1 ;[7] count it
> ;ifn sumex
ife sumex,<
ife pa2040,<
pushj p,rdstr ;[14] non SUMEX/IMSSS - simulate INTERLISP ed.
printx assembling non sumex tty i/o routine
>
> ;ife sumex
ttyadn: ;[7]
> ;[5] ifn tenex
ife tenex&<1-pa2040>,< ;[5]
setz c,
move b,[exp ttybsz!rd%top] ;break on tops-10 breaks
ife pa2040,<
rdtty
chkquo
erjmp ioecbp
>
ifn pa2040,<
pushj p,$$rdtty##
jump 16,ioecbp ;erjmp ioecbp
>
> ;[5]
hrrz b,b ;loc. left in buffer
movei t,ttybsz-1 ;total number avail (simulate sos)
sub t,b ;adjust for locations left
pop p,c
pop p,b
movem t,filbct(b)
hrr t,filttb(b)
hrli t,440700
movem t,filbpt(b)
popj p,
;TTOCUR - output portion of TTY buffer before current position
; uses t,a
; assumes B is FCB
; returns column position of prev char in C, ILDB ptr to current char in T
ttocur: hrr t,filttb(b) ;first put out the buffer up to cur pos
hrli t,440700 ;t is byte ptr
setz c, ;c is column counter
ttocr2: move a,t ;a _ new copy of byte ptr
ibp a ;consider new char
camn a,filbpt(b) ;if it is cur char, we are done
jrst ttocr1
;begin safety - prevent infinite loop in case ptr somehow messed up
hrrz a,t ;addr from byte ptr
subi a,^D50 ;compare to start of buffer + 50
camle a,filttb(b) ;still within buffer?
jrst ttocr1
;end safety
ildb a,t ;else do a real advance to this char
aoj c, ;and count it
pbout
jrst ttocr2 ;yes, loop
ttocr1: push p,b
movei a,.priou
rfpos ;RH(b) _ position in line
skipe b ;if not terminal, use counted C
hrrz c,b ;use position in terminal line
pop p,b
popj p,
;TTYSHL - Show the entire current line, with an arrow under the
; current position. No sideeffects.
;expects b to be set up
ttyshl: push p,t
push p,a
push p,c
;put out the line
psout
pushj p,ttocur ;put out start of line
move a,t ;now put out cur and rest of line
psout
;now put out a line with ^ under cur pos
;crlf unless old line ended in one
movei a,.priou ;see where we are now on line
push p,b
rfpos ;probably retype ended in a CRLF
hrrz b,b ;b _ current pos on line
hrroi a,[asciz /
/]
caile b,1 ;if not at beginning
psout ; then do CRLF
pop p,b
;spaces up to the right place
movei a,40 ;now blanks up to cur pos
ttshl4: sojl c,ttshl3 ;up to column shown in C
pbout
jrst ttshl4
;put out the ^
ttshl3: movei a,"^" ;now caret under cur. pos
pbout
hrroi a,[asciz /
/]
psout ;and CRLF
pop p,c
pop p,a
pop p,t
popj p,
;TTYFXL - clear rest of line and ask user for more.
;expects b to be set up
;t - PC to print if error msg
ttyfxl: pushj p,ttyini
movei a,.priou
jrst tryagn
ifn tenex,<
ife sumex,<
ife pa2040,<
; non SUMEX/IMSSS tty routine...Similar to Sumex/IMSSS PSTIN, i.e.
; corrections by typing a "[" and reverse-echoing characters deleted
; from the string. First newly-typed character gets a "]" first:
; "this is a mispe[ep]spelling". However unlike the Sumex code, it
; does not put you into binary mode, and it uses the same breaks as
; RD%TOP, i.e. ^G, ^L, ^Z, ESC, CR, LF.
; This code is the result of several iterations. It was originally
; supplied by Sumex, fixed up by DFloodPage at BBN, and finally edited
; by Hedrick.
; AC1 contains the string pointer
; AC2 contains the maximum number of bytes to input
; AC0 holds line character count, won't delete if count=0
; Note: The decrement bytepointer routine frequently sets
; Arithmetic Overflow. Thus, channel 6 is shut off
; during RDSTR, and reactivated afterwards
;Uses the following table to tell whether the terminal type is display.
;The user should make sure it is right for his site.
if1, <printx Be sure to change TRMTAB as appropriate for your site>
trmtab: exp 0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
trmmax=.-1-trmtab
;uses t,c. a and b are returned. Others preserved where used.
rdstr: push p,b ;save ac2
push p,e ;save ac5
push p,d ;save ac4
hlrz e,a ;get the left half of the pointer
move d,a ;move the whole pointer to d to use
cain e,777777 ;implicit bp?
hrli d,440700 ;convert to standard bytepointer
;args now set up:
; t - free, will be count of char's seen, initialized below
; a - free
; b - count of free chars in buffer
; c - free, will be flag bits below, 200000 = echo on, 100000 = display
; d - byte pointer into buffer
; e - free
;now set up COC and mode word, saving old on stack
move e,b ;save b in e
movei a,101 ;get old COC word
rfcoc
push p,b ;save old COC
push p,c
tlz b,(3B3) ;clear echo for ^A
tlz c,(3B1+3B7+3B9+3B11+3B13);clear echo for ^R, ^U, ^V, ^W, ^X
sfcoc ;new COC
rfmod ;get old RFMOD
push p,b ;save old mode word
;We have to set break on punct because rubout is a punctuation char on tenex!
trz b,77B23+3B29 ;new values for wakeup and mode
tro b,16B23+1B29 ;all except alphanum, ASCII mode
sfmod ;new mode
gttyp
caile b,trmmax ;legal terminal type?
setz b, ;no - use 0
setz c, ;flags to zero
skipe trmtab(b) ;except if display terminal
tro c,100000 ;set display flag
move b,e ;restore b
push p,d
;stack is now:
; initial d
; mode
; COC, c on top
; saved d
; saved e
; initial b
;finish setting up AC's as described above:
setz t, ;init count to 0
rdstr1: pbin ;get byte
andi a,177 ;[clh] make 7-bit
cain a,"V"-100 ;^V to quote
jrst rdqte
cain a,177 ;delete?
jrst rddel
cail a,40 ;characters .ge. 40 are always OK
jrst rdok ;This is just for speed
;It is a control character. We now test its special properties.
cain a,"A"-100 ;^A = delete
jrst rddel
cain a,37 ;37 is EOL (quote it to get ^_)
jrst rdeol
caie a,"U"-100 ;^U and
cain a,"X"-100 ;^X = delete line
jrst rddell
cain a,"R"-100 ;^R
jrst rdreds ; redisplay line
cain a,"W"-100 ;^W
jrst rddlwd ; delete word
movei e,1 ;now check terminators
lsh e,(a)
tdnn e,[xwd 001400,032200] ;null is right-most bit
jrst rdok ;not a terminator
jrst rdtrm ;is a terminator
rdeol: movei a,15 ;treat as CRLF
idpb a,d ;put down the CR
soj b, ;adjust count
movei a,12 ;and LF
idpb a,d
soj b,
tlz c,400000 ;*clear delete bit, or it gets
;* integer overflow and crashes if you
;* hit control-U.
jrst rdtrm1
rdok: aoj t, ;increment count
idpb a,d ;put the byte into the string
soje b,rdtrm1 ;if all bytes gone, leave
jrst rdstr1
rdqte: pbin
andi a,177 ;[clh]
jrst rdok ;get a quoted character
;delete line
rddell: cain t,0 ;at BOLN, nothing to do
jrst [movei a,7 ;beep
pbout
jrst rdstr1]
tlz c,400000 ;will start new line clean
trne c,100000 ;handle display mode
jrst rpdell
hrroi a,[asciz / XXX
/]
psout ;tell him line is cleared
rxdell: setz a, ;null for clearing line
move d,0(p) ;reinit pointer
setz t, ; count
move b,-6(p) ; and char's free
jrst rdstr1 ;now go for new line
;display version of delete line
rpdell: movei a,15 ;bare cr
pbout
jrst rxdell
;retype line
rdreds: push p,t ;put null at the end of string
setz t, ; here's the null
move a,d ; here's the end of string
idpb t,a ; put it there
pop p,t ;and restore things
trne c,100000 ;check display
jrst rpreds
hrroi a,[asciz /
/]
psout ;CRLF
rxreds: move a,0(p) ;initial pointer to buffer
psout ;now put it out
jrst rdstr1 ;and go back for more
;display version of retype line
rpreds: movei a,15 ;bare CR instead of CRLF
pbout
jrst rxreds
;delete word
rddlwd: cain t,0 ;delete word, error at BOLN
jrst [movei a,7
pbout
jrst rdstr1]
movei a,"_" ;echoes as backarrow
trnn c,100000 ;if display, DECBP will delete
pbout ;do it
;do first char always
ldb a,d ;first char to be deleted
pushj p,decbp ;start by deleting a char
aoj b, ;and adjust counts
soje t,rdstr1 ; if run out of char, done
pushj p,isanum ;is thing we deleted alphanum?
jrst rdstr1 ;no - we are finished
;do more as long as all alphanum (including first)
rddlw2: ldb a,d ;delete any more?
pushj p,isanum ;if alphanum, yes
jrst rdstr1 ; not, done
pushj p,decbp ;delete
aoj b, ;adjust counts
soje t,rdstr1 ; if run out, done
jrst rddlw2 ;otherwise, go back for more
isanum: caig a,"z"
caige a,"0"
popj p, ;null-(0 ; z)-177
caige a,"a"
caig a,"9"
jrst yesanm ;0 - 9 ; a - z
caig a,"Z"
caige a,"A"
popj p, ;9) - (A ; Z) - a(
yesanm: aos (p) ;fall through on A - Z
popj p,
rddel: cain t,0
jrst [movei a,7 ;at "BOLN," don't do a delete
pbout ;<beep!>
jrst rdstr1]
trne c,100000 ;display mode?
jrst rddel2 ;yes, skip this since DECBP deletes
ldb a,d ;echo the preceding character
pbout
movei a,"\" ;and backslash
pbout
rddel2: pushj p,decbp ;decrement the bytepointer
aoj b, ;take back that character
soj t, ;and decrement the line count
jrst rdstr1 ;get another byte
rdtrm: idpb a,d ;the final byte for character .lt. 37
tlz c,400000 ;*clear delete bit, or it gets
;* integer overflow and crashes if you
;* hit control-U.
soj b, ;read a byte, correct the count
rdtrm1: move t,b ;save b to be returned in t
; a to be returned is in d
setz a, ;stick a null at the end
move b,d
idpb a,b
;stack is now:
; initial d
; mode
; COC, c on top
; saved d
; saved e
; initial b
movei a,400000
movsi b,(1b6)
;start restoring things from stack
pop p,(p) ;not needed
movei a,101
pop p,b
sfmod ;mode
pop p,c
pop p,b
sfcoc ;COC
;put in return values before we clobber where they are
move b,t
move a,d
;resume the restoration
pop p,d ;ac's
pop p,e
pop p,(p) ;not needed
popj p, ;leave
decbp: repeat 4,<ibp d>
subi d,1
trnn c,100000 ;in display mode, also remove from screen
popj p,
;here to move back on a screen
push p,b
push p,c
push p,d
ildb d,d ;get thing being deleted
cail d,40 ;if printable, handle easily
jrst decprt
;here for control character
lsh d,1 ;multiply by 2, since 2 COC bits per word
movei a,.priou
rfcoc ;echo depends upon COC words
lshc b,(d) ;shift COC bits to high order end of 2
tlnn b,600000 ;if zero, nothing to back over
jrst decdon ; so done
tlnn b,400000 ;if one, ^X
jrst decctx ; so do ^X
cain d,11 ;if tab
jrst redisp ; I am lazy - redisplay the line
tlnn b,200000 ;if two, unknown
jrst redisp ; so redisplay
cain d,33 ;if esc
jrst decone ; one char
jrst redisp ;else unknown, so redisplay
;here for printable char
decprt: cain d,177 ;rubout is not printable
jrst decdon ; so do nothing
caig d,132 ;outside upper case
caige d,101
jrst decone ;it is just one char
movei a,.priou ;upper case - be sure we aren't mapping
rfmod
trnn b,tt%uoc
jrst decone ;not mapping - one char only
jrst dectwo ;mapping - two char's
;here for ^X type. Problem is that upper case when flagging is ^'A, etc.
decctx: pushj p,backsp ;backspace for the ^
jrst redisp
addi d,100 ;give us the upper case thing after the ^
jrst decprt ;now the char itself
;here when completely confused, to redisplay the line
redisp: movei a,15 ;start fresh
pbout
setz b, ;null to put at end of string
move a,(p) ;get d (current byte pointer)
idpb b,a ;put null next
move a,-4(p) ;start of line
psout
jrst decdon
;now the simple action routines
dectwo: pushj p,backsp
jrst redisp
decone: pushj p,backsp
jrst redisp
decdon: pop p,d
pop p,c
pop p,b
popj p,
;here is the backspacer:
backsp: movei a,.priou ;if at start of physical line, redisplay prev
rfpos
trnn b,777777 ;if zero, is at start
popj p, ;redisplay needed
movei a,.priou ;set for literal use of ^H
rfcoc
push p,b
tlz b,(3B17)
tlo b,(2B17)
sfcoc
hrroi a,[byte (7)10,40,10] ;bs,sp,bs
psout
pop p,b
movei a,.priou ;retore coc
sfcoc
aos (p)
popj p,
> ;ife pa2040
> ;ife sumex
> ;ifn tenex
ioecbp: pop p,c
pop p,b
adjstk p,-1
jrst ioerp
reloc
ttybsz==^D250 ;no of char's in buffer
ttybuf: block ^D50 ;buffer itself
reloc
puttty: move a,filcmp(b)
pbout
chkquo
erjmp ioerp
popj p,
ttyini: setzm filbct(b) ;this is done by breakin
popj p,
subttl actual I/O for terminals openned as files
;on tenex, this routine is only used for the controlling terminal
getcht: sosge filbct(b)
pushj p,tdvadv
ildb a,filbpt(b)
jumpe a,getcht
cain a,"Z"-100 ;control-Z?
jrst simeof ;yes - is really eof
jrst getchr
;device-dependent open routine
tdvopn: tro g,of%wr ;need write priv's to do echo output
setzm filbct(b) ;force read on first get
setzm filter(b) ;no saved errors
movei a,1 ;get a one page buffer
pushj p,alcbuf
jrst openfi
tdvadv:
ife tenex&<1-pa2040>,< ;[7]
skipe filter(b) ;if any stored error
jrst simerx ;do it and abort
push p,[exp 4] ;construct arg block for texti - size
push p,[exp rd%top!rd%jfn]
move t,filjfn(b)
hrl t,t
push p,t
hrro t,filbuf(b) ;place to put input
push p,t
push p,[exp 5000] ;no of char's allowed
movei a,-4(p)
ifn pa2040,<
pushj p,$$texti##
hrrzm a,filter(b) ;save error for simerr
>;ifn pa2040
ife pa2040,<
texti
chkquo
ercal txtier
>;ife pa2040
movei t,4777 ;no. of char's remaining
sub t,(p)
adjstk p,-5
> ;ife tenex
ifn tenex&<1-pa2040>,< ;[7] begin
push p,b
push p,c
hrro a,filbuf(b) ;place to put input
move b,[exp 5000] ;count
ifn sumex,<
movei c,032012 ;break on ^Z, LF
pstin ;[14] sumex/imsss line read
ldb t,a ;get terminator
caie t,15 ;cr?
jrst tdvadn ;no, normal
movei t,12 ;yes, add lf
idpb t,a ;
subi b,1 ;count it
>
ife sumex,<
pushj p,rdstr ;[14] non-sumex simulation of line read
>
tdvadn: ;
movei t,4777 ;no of char's remaining
subi t,(b)
pop p,c
pop p,b
> ;ifn tenex [7] ^^
jumpl t,tdvadv ;none there - try again or do error now
movem t,filbct(b) ; (caller assumes we got at least 1)
hrr t,filbuf(b) ;initial byte ptr
hrli t,440700
movem t,filbpt(b)
popj p,
setpt: setzm filbct(b) ;setpos (curpos is curpbx)
skipe filter(b) ;activate stored errors
pushj p,simerr
jrst setpbx
ioerp5: adjstk p,-6 ;note - 5 to restore stk, 1 to abort caller
jrst ioerp
txtier: hrrzm a,filter(b) ;save error for simerr
popj p,
;TDOCUR - output portion of TTY buffer before current position
; uses t,a
; assumes B is FCB
; returns column position of prev char in C, ILDB ptr to current char in T
tdocur: push p,b
push p,d
push p,e
hrr t,filbuf(b) ;first put out the buffer up to cur pos
hrli t,440700 ;t is byte ptr
hrrz a,filjfn(b) ;a is jfn
setz c, ;c is column counter
hrrz d,filbuf(b) ;d _ end of buffer
addi d,1000
move e,filbpt(b) ;e _ byte pointer for end
tdocr2: move b,t ;a _ new copy of byte ptr
ibp b ;consider new char
camn b,e ;if it is cur char, we are done
jrst tdocr1
;begin safety - prevent infinite loop in case ptr somehow messed up
hrrz b,t ;addr from byte ptr
camle b,d ;still within buffer?
jrst tdocr1
;end safety
ildb b,t ;else do a real advance to this char
aoj c, ;and count it
bout
jrst tdocr2 ;yes, loop
tdocr1: rfpos ;RH(b) _ position in line
skipe b ;if not terminal, use counted C
hrrz c,b ;use position in terminal line
pop p,e
pop p,d
pop p,b
popj p,
;TDVSHL - Show the entire current line, with an arrow under the
; current position. No sideeffects.
;expects b to be set up
tdvshl: push p,t
push p,a
push p,b
push p,c
;put out the line
pushj p,tdocur ;put out start of line
hrrz a,filjfn(b)
move b,t ;now put out cur and rest of line
move t,c ;t _ position of ^ on line
setz c,
sout
;now put out a line with ^ under cur pos
;crlf unless old line ended in one
rfpos ;probably retype ended in a CRLF
hrrz b,b ;b _ current pos on line
caig b,1 ;if not, crlf
jrst tdvsh1
hrroi b,[asciz /
/]
setz c,
sout
tdvsh1:
;spaces up to the right place
movei b,40 ;now blanks up to cur pos
tdvsh4: sojl t,tdvsh3 ;up to column shown in t
bout
jrst tdvsh4
;put out the ^
tdvsh3: movei b,"^" ;now caret under cur. pos
bout
hrroi b,[asciz /
/]
setz c,
sout ;and CRLF
pop p,c
pop p,b
pop p,a
pop p,t
popj p,
;TDVFXL - clear rest of line and ask user for more.
;expects b to be set up
;t - PC to print if error msg
tdvfxl: pushj p,ttyini
hrrz a,filjfn(b)
jrst tryagn
subttl line and page routines (all ascii modes)
;Note that getln is called by readln. Thus I class it as a high-level
; function and so abort the operation if eof is set. The low-level
; functions (get, put, etc.) will try to go on even if eof is set.
getlx1: pushj p,@filget(b)
getlnx: skipe fileof(b) ;stop after errors
popj p,
skipg fileol(b)
jrst getlx1
jrst @filget(b)
putlnx: movei t,15
movem t,filcmp(b)
pushj p,@filput(b)
movei t,12
movem t,filcmp(b)
jrst @filput(b)
putpgx: movei t,15
movem t,filcmp(b)
pushj p,@filput(b)
movei t,14
movem t,filcmp(b)
jrst @filput(b)
subttl i/o routines for record files, sin/sout i/o used
;args to getbx and putbx:
; b - fcb
; c - count of words to transfer
getbx: move e,b ;record read - save fcb
hrrz a,filjfn(e) ;source
hrri b,filcmp(e) ;destination
hrli b,444400 ;binary
movem c,fillct(e) ;store count for error recov. and putx
movn c,c ;count (negative means stop on count)
setz d,
sin
erjmp ioerbx
popj p,
getxbx: move e,b ;similar to getbx, but continue old read
hrrz a,filjfn(e)
hrri b,filcmp(e)
hrli b,444400
add b,fillct(e) ;start after last record
movem c,fillct(e)
sub c,fillct(e) ;reduce count that much
movn c,c
setz d,
sin
erjmp ioerbx
popj p,
ioerbx: addm c,fillct(e)
move d,e
jrst ioer
putbx: move e,b ;record write - save fcb
putby: hrrz a,filjfn(e) ;source - entry for putx
hrri b,filcmp(e) ;destination
hrli b,444400
movem c,fillct(e) ;count
movn c,c ;make count negative
setz d,
skipe c ;[40] zero is special
sout
chkquo
erjmp ioerbx
popj p,
putxbx: move e,b ;record rewrite
hrrz a,filjfn(e)
rfptr ;see where we are now
erjrst eioer ;[7]
sub b,fillct(e) ;get to beginning of record
sfptr
erjrst eioer ;[7]
move c,fillct(e) ;size of record
jrst putby ;now put it out
curpbx: move d,b ;get current byte no.
hrrz a,filjfn(d)
rfptr
erjrst ioer ;[7]
movem b,1(p) ;return value goes here
popj p,
setpbx: move e,d ;suppress get flag
move d,b ;save fcb
hrrz a,filjfn(d)
move b,c ;place to go
sfptr
erjrst ioer ;[7]
move b,d ;restore b for get routine
jrst posdon ;common code to clear status and do get
bxopn: pushj p,openfi
bxini: setzm fillct(b) ;initialization for open
popj p,
subttl i/o routines for tape - sinr/soutr i/o used
;args to getbxr and putbxr:
; b - fcb
; c - count of words to transfer
getbxr: move e,b ;record read - save fcb
hrrz a,filjfn(e) ;source
hrri b,filcmp(e) ;destination
hrli b,444400 ;binary
movem c,fillct(e) ;store count for error recov. and putx
move t,c ;save requested count
movn c,c ;count (negative means stop on count)
setz d,
sinr
erjmp ioerbx
add c,t ;get no. words actually read
movem c,fillct(e) ;save as real count
popj p,
putbxr: move e,b ;record write - save fcb
hrrz a,filjfn(e) ;source - entry for putx
hrri b,filcmp(e) ;destination
hrli b,444400
movem c,fillct(e) ;count
movn c,c ;make count negative
setz d,
skipn c ;[40] zero is special
hrri b,[exp 0] ;[40] stop immediately
soutr
chkquo
erjmp ioerbx
popj p,
lstrec: move a,fillct(b) ;get size of last record
movem a,1(p)
popj p,
;Here are the routines for handling text with SINR and SOUTR
putcx: sosge filbct(b) ;write a character
jrst ptcxer ;ran out of space in buffer - line too long
move a,filcmp(b)
idpb a,filbpt(b)
popj p,
ptcxer: movei a,iox20 ;illegal tape record size
movem a,filerr(b)
jrst ioerpx ;simulate I/O error
getcx: sosge filbct(b) ;read a character
jrst getcxl ;end of buffer - this is end of line
getcxn: ildb a,filbpt(b)
andi a,177
jumpe a,getcx ;ignore nulls
move a,@filcht(b)
setzm fileol(b) ;the only end of line is end of record
hrrzm a,filcmp(b)
popj p,
;GETCXL - here from GETCX when run out of chars in record. We simulate
; end of line, and set things so the next character read forces going
; to a new record.
getcxl: movei a,getlx ;make the next GETCH get a new line
movem a,filget(b)
movei a,1 ;set EOL
movem a,fileol(b)
movei a,40 ;and call it a blank, as per Pascal std.
movem a,filcmp(b)
popj p,
;Here we have the routines to go to a new record. there is a special
;version for format F
putlx: push p,c ;write the buffer
push p,b
hrrz a,filjfn(b)
movn c,filbfs(b) ;compute number of bytes to dump
add c,filbct(b) ;subtract number not actually used
move b,filpbp(b)
skipn c ;[40] zero is special
hrri b,[exp 0] ;[40] stop immediately
soutr
chkquo
erjmp badpag
pop p,b
move a,filbfs(b) ;reinitialize state
movem a,filbct(b)
move a,filbfp(b)
movem a,filbpt(b)
pop p,c
popj p,
;PUTLXX - special version for format F - writes an exact line
putlxx: movei a,40 ;put blanks until the record is full
skipg c,filbct(b) ;space left?
jrst putlx ;no - do output now
idpb a,filbpt(b) ;yes - put in spaces
sojg c,.-1 ;as long as there is space
setzm filbct(b) ;now no space left
jrst putlx ;do normal write
getlx: movei a,getcx ;restore normal reader
movem a,filget(b)
push p,c
push p,b
hrrz a,filjfn(b)
movn c,filbfs(b)
move b,filpbp(b)
sinr
erjmp badpag
pop p,b
add c,filbfs(b) ;compute actual number transferred
;[40] remove subi c,1 - code must work for empty lines
movem c,filbct(b)
move a,filbfp(b)
movem a,filbpt(b)
pop p,c
jrst getcx ;[40] was jrst getcxn
;CHROPX - mode-specific open. This is bascially a version of
; CHROPN, the byte-mode open, except that it has to test for
; format F and use a special PUTLN routine.
chropx: skipe filerr(b) ;byte mode I/O open
popj p, ;no-op if error
;Here is the code that is always done
;The following is in fact just CHROPN
pushj p,openfi ;now open it
chrox1: pushj p,logopn ;compute logical parameters
move t,filbfp(b) ;physical param's = logical ones
movem t,filpbp(b)
move t,filbfs(b)
movem t,filpbs(b)
;This part sets up for special EOL handling because of the nature of this mode
hrrz t,filcht(b) ;don't censor EOL char's, since they aren't EOL
cain t,norchx ;if a char table that censors, change it
movei t,norcht
cain t,lcchx
movei t,lccht
hrrm t,filcht(b) ;put back correct table
;We have to "prime the pump" for reading. this mode is different from others
; because it will manufacture an EOL char when the buffer empties. So if
; we just start with an empty buffer, we get an initial EOL!
skpwrt
pushj p,getcxl ;if reading, init so the first GET reads
;The rest of this code is checking for writing a tape in format F, in which
; case we have to set up a special routine for PUTLN.
;Writing
skpwrt ;if reading, no problem
popj p,
;a tape
move h,b ;save FCB
hrrz a,filjfn(h) ;see if this is a tape
dvchr
ldb b,[point 9,b,17] ;get device type
caie b,.dvmta ;if not tape, nothing to do
jrst cpopjh ;exit, restoring B from H
;in format F
; Since we are writing we can't just look at the label. We have to
; predict whether it will be format F. It turns out that this will
; happen only if the tape is labelled and the user has specified
; ;FORMAT:F.
;labelled
push p,[exp 3] ;place to put result
push p,[exp 0]
push p,[exp 0]
hrrz a,filjfn(h)
movei b,.morli ;look at label
movei c,-2(p)
mtopr
erjmp chroxx ;not labelled, exit restoring stack and B
move a,-1(p) ;label type
cain a,.ltunl ;if unlabelled, forget this stuff
jrst chroxx ;not labelled, exit restoring stack and B
;the user has specified format F
hrroi a,-2(p) ;put results in stack
setzm -2(p)
hrrz b,filjfn(h)
movei c,js%at1 ;return attr
hrroi d,[asciz /FORMAT/]
jfns
erjmp chroxx ;not format F, exit restoring stack and B
move a,-2(p)
came a,[asciz /F/]
jrst chroxx ;not format F, exit restoring stack and B
;We now know that we will need the special format F PUTLN. We have to set
; up the record size, so it knows how much to fill. This is more complex
; than it sounds. Since the tape is being created, we can't just get the
; record size from the label. We have to predict what the monitor will
; decide on. This turns out to be the user's RECORD attribute if there is
; one, or the block size if not.
;the user's RECORD attribute
hrroi a,-2(p) ;put rec size in stack
hrroi d,[asciz /RECORD/]
jfns
erjmp chronr ;no record attribute, use default
hrroi a,-2(p)
movei c,^D10
nin
erjmp chronr ;odd - use default too
move c,b
jrst chrofr ;found record size
;the block size if there is not RECORD attribute
chronr: hrrz a,filjfn(h) ;no record attr - use default
movei b,.morrs
mtopr
erjmp chroxx ;can't find that way either, treat as not F
;here the above two cases join - we have the record size in C
chrofr: camle c,filbfs(h) ;too big for buffer?
jrst rectb ;record too big
movem c,filbfs(h) ;use this instead of buffer size
movem c,filbct(h) ;we start with a full buffer available
movei a,putlxx ;get special PUT for format F
movem a,filpln(h)
;exit, restoring stack and B
chroxx: adjstk p,-3
move b,h
popj p,
rectb: adjstk p,-3 ;record too big
move b,h
jrst ptcxer ;give error message
;LOGCLX - mode-specific closer - force the buffer
logclx: skpwrt ;only if writing
popj p,
move a,filbct(b) ;anything in this buffer?
came a,filbfs(b)
jrst @filpln(b) ;yes - force it
popj p, ;no
loginx: skpwrt ;breakin
jrst getcxl
move a,filbfs(b)
movem a,filbct(b)
move a,filbfp(b)
movem a,filbpt(b)
popj p,
subttl magtape initialization
;This is a device-dependent openning routine for magtape. It is used
;when the user leaves the I/O mode to us. Here is what we do
; format U, default, and unlabelled: "stream I/O": out: WRDOPN, in: CHROPN
; format F, D, and S: "record I/O": text:CHROPX, binary:BXOPN
;Unfortunately, we have to do the OPENF first in order to be able to
;read labels.
;In addition, if this is an output file and the user hasn't specified
;a format, we want to specify format U. This is somewhat harder than it
;sounds, since we can't specify the format after a GTJFN. However
;since format U will default to stream I/O, we just make it use WRDOPN,
;which uses 36 bits. This will get us format U by default.
;Input has to use CHROPN for format U in case the tape is foreign, in
;which case DEC is nice to us by forcing 8 bits internally.
;all three of the possible openning routines begin this way
mtaopn: skipe filerr(b)
popj p,
;might as well set up the stack now - everybody needs it
push p,[exp 5]
push p,[exp 0]
push p,[exp 0]
push p,[exp 0]
push p,[exp 0]
move h,b ;save B
skpwrt ;if open for write
jrst mtard ;not - no need to force 36 bits
;Part I - Check parameters for output file
;check unlabelled
hrrz a,filjfn(h)
movei b,.morli ;look at label
movei c,-4(p)
mtopr
erjmp mtawrd ;unlabelled, force word
move a,-3(p) ;get label type
cain a,.ltunl
jrst mtawrd ;unlabelled, force word
;check U or default
hrroi a,0(p) ;put results in stack
setzm 0(p)
hrrz b,filjfn(h)
movei c,js%at1 ;return attr
hrroi d,[asciz /FORMAT/]
jfns
erjmp mtawrd ;unlabelled, force word
;some real format
move a,(p)
camn a,[asciz /U/]
jrst mtawrd ;format U, force word
;here is the code for output files other than U - done separately from
;input since we don't want to do the MTOPR again
mtalog: move b,h ;openfi needs b
pushj p,openfi ;open with logical byte size
jrst mtaans ;now go handle ans type
;Part II - Check parameters for input file
mtard: pushj p,openfi
hrrz a,filjfn(h) ;now we can look at the label
movei b,.morli
movei c,-4(p)
mtopr
erjmp mtachr ;unlabelled, use CHROPN
move a,-3(p) ;get label type
cain a,.ltunl
jrst mtachr ;unlabelled, use CHROPN
move a,0(p) ;format
cain a,"U"
jrst mtachr ;format U, use CHROPN
;jrst mtaans
;Part III:
;Here are the exit routines. they set up the dispatch vector, and then
; go to the openning routine after the OPENF
;now we know we have format F, D, or S - handle it in some record mode
mtaans: adjstk p,-5 ;[41] restore state
move b,h
skipge filcnt(b)
jrst mtabx ;binary - BXOPN
;jrst .+1
;text - use CHROPX
movei a,fm%rec
pushj p,setdsp ;set up dispatch block
jrst chrox1 ;and go to CHROPX
;binary - use BXOPN
mtabx: movei a,fm%rec
pushj p,setdsp
jrst bxini
;format U input - use CHROPN
mtachr: adjstk p,-5 ;[41]
move b,h ;restore FCB
movei a,fm%chr
pushj p,setdsp ;set up dispatch block
jrst chrop1
;format U output - use WRDPON
mtawrd: adjstk p,-5 ;[41]
move b,h ;restore FCB
;we haven't done OPENF yet, so we can just JRST to normal routine
movei a,fm%wrd
pushj p,setdsp ;set up dispatch block
jrst wrdopn
subttl i/o error routines
illfn: move d,b ;here for illegal function
movei a,mtox1 ;"illegal function" (from mtopr)
movem a,filerr(d)
jrst erp. ;these errors are fatal
unimp==illfn ;here for unimplemented function
ife tenex,<
;chkquo - special thing designed to be used with ERCAL after a
;jsys that may write to disk. If quota is exceed, gives a
;message that looks just like the EXEC's, and retries the jsys
;if continued.
quochk: push p,a
push p,b
movei a,400000
geter
tlz b,777777 ;b _ error code
caie b,iox11 ;is it quota problem?
cain b,pmapx6
jrst isquot ;yes
;not a quota problem, do the next instruction, including erjmp/cal
;simulation.
move a,-2(p) ;ret addr
hlrz b,(a) ;next inst
cain b,(erjmp) ;is erjmp?
jrst dojmp
cain b,(ercal) ;is ercal?
jrst docal
retba: pop p,b ;no, normal return
pop p,a
popj p,
;here are the erjmp/cal simulations
dojmp: hrrz b,(a) ;address to go to
hrrm b,-2(p) ;make us return there
jrst retba
docal: hrrz a,(a) ;address to call
pop p,b
exch a,(p)
adjstk p,-1 ;we now have goto addr 1(p)
aos (p) ;return after the next ercal
jrst @1(p) ;this is pjrst
;here if it is a quota problem
; print a message, and then prepare to retry the instruction
isquot: hrroi a,[asciz / Quota exceeded or disk full at /]
esout
push p,c
hrrz b,-3(p) ;return addr
subi b,2 ;the actual jsys addr
hrrm b,-3(p) ;reset to return there
movei c,10 ;base 8
movei a,.priou
nout
jfcl ;not sure how to handle errors here
hrroi a,[asciz /
[Find some space, then type CONTINUE]
/]
psout
; Finally we are ready to restore to the user's context and continue,
; is user types CONTINUE
pop p,c ;restore ac's in case user does EXAMINE
pop p,b
pop p,a
haltf ;let him delete some files
popj p,
> ;ife tenex
ioerpx: move a,filerr(b) ;entry for those who already know the error
jrst ioerp2
eioer: skipa b,e ;entry if fcb is in e
ioer: move b,d ;special entry if fcb is in d
;ioerp is the main error printer. it preserves b up
ioerp: push p,b
movei a,400000 ;use current process
geter
hrrz a,b ;error is in rh
pop p,b
movem a,filerr(b) ;and save new error
ioerp2: move t,filbad(b) ;now set eof and eoln
movem t,fileof(b)
movem t,fileol(b)
skipl filcnt(b) ;if ascii
setzm filcmp(b) ;clear the component (read/ln needs this)
move t,filflg(b)
caie a,iox4 ;end of file always enabled
trne t,fl%ioe ;user error handling?
popj p, ;yes - let user handle it
move d,b
erp.:: pushj p,erp ;now put out message
jrst endl ;and stop (fatal)
spec==1
erp..::
erp: hrroi a,[asciz / /]
esout
movei a,.priou ;now the error message
move b,filerr(d)
hrli b,400000 ;current process
setz c,
erstr
jfcl
jfcl
hrroi a,[asciz / - /] ;now the file name
psout
skipn filjfn(d) ;[15]
popj p, ;if no JFN, nothing to print
movei a,.priou
hrrz b,filjfn(d)
setz c,
jfns
erpdon: hrroi a,[asciz /
/]
psout
popj p,
;various file cleanup stuff:
;gotoc. - cleanup for goto
; b - new o
; c - new p
; d - where to go
;any files above the new p and below the current p are to be released
gotoc.: push p,c ;new P
push p,b ;new O
hrrz e,p ;release if leq e
hrrz f,c ;and gt f
movei g,blktab ;loop over blktab
;loop on blktab
gotol: move b,(g) ;get the fcb addr there
camle b,f ;if leq f
camle b,e ;or g e
jrst gotocn ; don't do anything with it
;here if the FCB is in area to be released
setz c, ;yes - kill it
pushj p,doclos
setzm filtst(b) ;and indicate no longer valid
setzm (g) ;clear table entry
setom blklck-blktab(g) ;and release lock on it
;end of loop on blktab
gotocn: camge g,lstblk
aoja g,gotol ;if any more to look at, do so
;now we have killed all the files that we should have. Do the goto
pop p,o ;new O
pop p,t ;new P
move p,t
jrst (d) ;go to place where we should
;dispc. - dispose of a record containing a file. Search our
;database for one that might be it
; b - addr of record
; c - length of record
dispc.: push p,b ;save b and c
push p,c
move f,b ;f - lower limit
move e,b
add e,c ;e - upper limit
movei g,blktab ;loop over blktab
;loop on blktab
dispfl: move b,(g) ;get the fcb addr there
caml b,f ;if lt f
caml b,e ;or ge e
jrst dispfn ; don't do anything with it
;here if the FCB is in area to be released
setz c, ;yes - kill it
pushj p,doclos
setzm filtst(b) ;and indicate no longer valid
setzm (g) ;clear table entry
setom blklck-blktab(g) ;and release lock on it
;end of loop on blktab
dispfn: camge g,lstblk
aoja g,dispfl ;if any more to look at, do so
pop p,c
pop p,b
popj p,
quit:
end: movei g,blktab ;loop through all files
endcl: skipn b,(g) ;get the fcb addr there
jrst endcn ;nothing there, try next
setz c, ;kill it
pushj p,doclos ;close it
setzm filtst(b) ;and indicate no longer valid
setzm (g) ;clear table entry
setom blklck-blktab(g) ;and release lock on it
endcn: camge g,lstblk ;go to next, if any
aoja g,endcl
endl:: haltf ;that's all, folks
hrroi a,[asciz /Can't continue
/]
esout
jrst endl
erstat: move t,filerr(b) ;let user see his error
movem t,1(p)
popj p,
analys: skipn filerr(b) ;let him see error string
popj p,
move d,b
pushj p,erp
popj p,
;[43] - save the FCB in D, and change FILxxx(B) to FILxxx(D)
clreof: move d,b ;[43] save FCB
skipn a,filjfn(d) ;if no file involved,
jrst clrOK ; then this is just bookkeeping
hrrz a,a ;otherwise clear monitor's error bits
gtsts
erjmp ioerp ;if bad jfn, failed
jumpge b,clrOK ;if file not open, nothing to do
tlzn b,(gs%eof!gs%err) ;now reset with error bits off
jrst clrOK ;no errors, nothing to do
ststs
erjrst ioer ;[7][43]
clrOK: move t,filbad(d) ;set to normal eof
trc t,1 ;reverse of bad status
movem t,fileof(d)
setzm filerr(d)
move b,d ;[43]
;[36] removed setting EOLN
popj p,
notop: move d,b ;where erp. wants it
movei a,desx5 ;not open
movem a,filerr(d)
jrst erp.
subttl main file name getter for PROGRAM statement
;AC usage for getfn.:
; b - fcb
; c - pointer to name in ascii, length=10 always
; lh - flags for gtjfn
; h - used to save b
; garbarges all ac's except b
ife tenex,<
;note - this routine is not reeentrant. Since it is used in the
; startup code, presumably it doesn't have to be.
getfn.: pushj p,initb. ;always safe to init block at startup
move h,b
move d,(c) ;make up prompt and default
movem d,fnprom
movem d,deffil
movem d,hlpfn1
movem d,hlpfn2
move d,1(c)
movem d,fnprom+1
movem d,deffil+1
movem d,hlpfn1+1
movem d,hlpfn2+1
caie h,input## ;if input or output, use TTY:
cain h,output##
jrst .+2
jrst getfno
move a,[asciz /TTY:/]
movem a,deffil
move a,[ascii /TTY: /]
movem a,hlpfn2
move a,[ascii / /]
movem a,hlpfn2+1
;C already has the "substantive" bits - make sure odd ones are off
getfno: tlz c,(gj%fns!gj%sht) ;long form
hllm c,getfna+.gjgen ;use flag bits
setzm getfna+.gjdev ;clear rest of arg block
move a,[xwd getfna+.gjdev,getfna+.gjdev+1]
blt a,getfna+16
setzm cmjfn
movei a,bufsiz*5 ;init cmd block
movem a,cmdblk+.cmcnt ;space left
setzm cmdblk+.cminc ;char's not yet parsed
move a,cmdblk+.cmbfp
movem a,cmdblk+.cmptr ;next input
;entry for error
;main loop
getfn1: skipe a,cmjfn ;if any jfn gotten
rljfn ;release it
erjmp .+1
setzm cmjfn ;now no jfn
;prompt
movei a,cmdblk
movei b,iniblk ;prompt
comnd
erjmp getfer
tlne a,(cm%nop) ;error?
jrst getfer ;yes - message and try again
;entry for reparse
;get file name
getfn2: skipe a,cmjfn ;if any jfn gotten
rljfn ;release it
erjmp .+1
setzm cmjfn ;now no jfn
movei a,cmdblk
movei b,filblk ;file name
comnd
erjmp getfer
tlne a,(cm%nop) ;error?
jrst getfer ;yes - message and try again
hrrzm b,cmjfn ;remember JFN in case have to close it
movem b,filjfn(h) ;and put in FCB
;confirm
movei a,cmdblk
movei b,cfmblk ;confirm
comnd
erjmp getfer
tlne a,(cm%nop) ;error?
jrst getfer ;yes - message and try again
;exit
move b,h
popj p,
iniblk: <.cmini>B8
z
z
z
filblk: <.cmfil>B8+cm%dpp+cm%hpp+cm%sdh
z
xwd -1,hlpfil
xwd -1,deffil
cfmblk: <.cmcfm>B8
z
z
z
reloc
hlpfil: ascii /One of the following:
File spec. for the Pascal file /
hlpfn1: block 2
ascii /
Carriage return to use default, /
hlpfn2: block 2
asciz /
/
deffil: block 3 ;default name
fnprom: block 2 ;file name
asciz / : /
cmdblk: getfn2 ;reparse to loop
xwd .priin,.priou ;jfn's
xwd -1,fnprom ;^R
xwd -1,cmdbuf ;start of buffer
z ;next to parse
z ;left
z ;char's not parsed
xwd -1,atbuf ;atom buf
exp 5*bufsiz ;size of atom buf
exp getfna ;addr of gtjfn arg
bufsiz==^D30
cmdbuf: block bufsiz
atbuf: block bufsiz
cmjfn: block 1 ;jfn needs releasing
getfna: z ;gen
xwd .priin,.priou ;jfn's
block 15 ;other junk for COMND
reloc
getfer: movei a,[asciz / /]
esout ;give ?, etc.
movei a,.priou ;now error message
hrloi b,400000
setz c,
erstr
jfcl
jfcl
hrroi a,[asciz /
/]
psout
jrst getfn1
> ;ife tenex
ifn tenex,<
getfn.: pushj p,initb. ;always init block at startup
move h,b
setzm filflg(b) ;clear temp bit
move d,(c) ;d,e,f _ asciz prompt message
move e,1(c)
move f,[asciz / : /]
hllz g,c ;g _ gtjfn flags
getfn1: hrroi a,d ;prompt
psout
move a,g
move b,[xwd .priin,.priou]
gtjfn
jrst getfer
getfnx: movem a,filjfn(h)
move b,h
popj p,
getfer: cain a,gjfx34 ;? typed
jrst getfhl ;print help
cain a,gjfx33 ;no name? - treat as default
jrst getfdf
getfe1: movei a,[asciz / /]
esout ;give ?, etc.
movei a,.priou ;now error message
hrloi b,400000
setz c,
erstr
jfcl
jfcl
hrroi a,[asciz /
/]
psout
jrst getfn1
getfhl: hrroi a,[asciz /
One of the following:
File spec for the PASCAL file /]
psout
movei a,.priou ;print the file name
hrroi b,d
movni c,12
sout
hrroi a,[asciz /
Carriage return to use default, /]
psout
;Now give him the right default
caie h,input##
cain h,output##
jrst getfh1
movei a,.priou
hrroi b,d
movni c,12
sout
jrst getfh2
getfh1: hrroi a,[asciz /your terminal/]
psout
getfh2: hrroi a,[asciz /
/]
psout
jrst getfn1
;here for default (TTY: for INPUT and OUTPUT, else filename)
getfdf: move a,g ;flags user specified
tlo a,(gj%sht) ;but short form
tlz a,(gj%xtn!gj%fns) ;file spec as string
hrroi b,d
caie h,input##
cain h,output##
hrroi b,[asciz /TTY:/]
gtjfn
jrst getfe1
jrst getfnx ;done, return jfn and exit
> ;ifn tenex
;initb. - make file control block be fresh and clean
; b - addr of fcb
;saves all ac's
initb.: push p,a
;We must enter this into the table of known blocks before setting
; filtst, in order to prevent a race condition if the user ^C's
; and restarts during this routine. We must make sure that the
; code as pasin1 knows to clear filtst.
;enter it into the table of known blocks
hrli a,-blklen ;aobjn word for searching block table
hrri a,blklck ;we are actually searching table of locks
aose (a) ;take it if free. Skip if it worked
;This code is designed to be reentrant, so
;a single instruction must test and take it
aobjn a,.-1 ;failed, try again
jumpge a,initbf ;failed to find an index location
movem b,blktab-blklck(a) ;found it, save block addr
movei a,blktab-blklck(a) ;and update high-water mark
camle a,lstblk
movem a,lstblk
;init the block
initbc: hrli a,protob ;blt prototype block to it
hrr a,b
blt a,filcmp(b)
movei a,filcmp(b) ;now initializations that depend upon address
movem a,filptr(b)
movem a,filcnt(b) ;don't have info to set up LH yet
pop p,a
popj p,
;init.b is a special entry for the compiler's use
init.b: push p,a
jrst initbc
initbf: pushj p,blktbe ;print error message
jrst initbc ;init the block anyway if he says to
;prototype block
protob: exp 0 ;FILPTR== 0 ;pointer to filcmp
exp 0 ;FILEOF== 1 ;input: 0 == normal state
; 1 == eof or error
;output:1 == normal state
; 0 == error
exp 0 ;FILEOL== 2
exp 0 ;FILERR== 3 ;RH - last error no, LH - enabled
exp 0 ;filjfn==4 ;jfn
exp 0 ;filspc==5 ;pointer to block with file spec in it
exp 0 ;filflg==6 ;flags
exp 1 ;filbad==7 ;contents to set fileof to if error
exp norchx ;filcht==10 ;pointer to character mapping table
exp 0 ;fils11==11
exp 0 ;fils12==12
exp 0 ;fils13==13
exp 0 ;fillts==14
exp 0 ;filbuf==15 ;buffer for paged files:
;LH == # of pages, RH == addr of first word
;filr11 through filr99 must be contiguous
;filr11==16 ;first routine
exp notop ;filget==16 ;routine for GET
exp notop ;filput==17 ;routine for PUT
exp notop ;filgln==20 ;routine for GETLN
exp notop ;filpln==21 ;routine for PUTLN
exp 0 ;filclo==22 ;device-dependent close
exp unop+filr99+1 ;filr99==23 ;pointer to other routines
exp 0 ;fils15==24 ;another state variable
exp 0 ;fils16==25
exp 0 ;fils17==26
exp 0 ;fils20==27
exp 0 ;fils21==30
exp 0 ;FILLNR==31 ;IF ASCII MODE - LINENR
exp 0 ;FILCNT==32 ;LH== neg size of component
; if text file: zero
;test sign bit of this loc to see if an ASCII file
;RH== ADDRESS OF FIRST WORD IN COMPONENT
exp 0 ;filst1==33 ;state variables for special I/O modes
exp 0 ;filst2==34
exp 0 ;filst3==35
exp 0 ;filst4==36
exp 0 ;filst5==37
exp 314157 ;filtst==40 ;should be 314157 if file is open
exp 0 ;filind==41 ;location in index
exp 0 ;42 - spare
exp 0 ;FILCMP==43 ;FIRST WORD OF COMPONENT
;ttypr. - do initial get for INPUT
ttypr.: hrrz a,input##+filjfn
dvchr ;see if a tty
ldb c,[point 9,b,17] ;dev type field
caie c,.dvtty ;if not tty, forget it
jrst ttyprg
hrrz a,input+filjfn
hrroi b,[asciz /[INPUT, end with ^Z: ]
/]
setz c,
sout
ttyprg: movei b,input##
jrst getch
subttl buffered I/O - text routines
filpbp==fils12 ;physical buffer byte pointer
filpbs==fils13 ;physical buffer size
filter==fils15 ;place to store defered error
;These routines do ildb/idpb from a one page buffer, which is filled/
; emptied by sin/sout. It is a bit confusing because the I/O is
; often done in 36 bit mode, for efficiency. thus physical buffer
; size is the number of 36 bit bytes in the buffer when you are in
; this "word mode", and the number of logical bytes when in normal
; "character mode". Also, physical buffer byte pointer points to
; the beginning of the buffer, having a byte size of 36 in word mode,
; and the logical byte size in charcter mode. These routines are
; inefficient for mag tape when the record size is much less than
; a page, as proper overlapping of I/O and computation requires our
; buffer to be near the record size or smaller.
putchb: sosge filbct(b) ;write a character
pushj p,wrtbuf ;put out the buffer
move a,filcmp(b)
idpb a,filbpt(b)
popj p,
getchb: sosge filbct(b) ;read a character
pushj p,reabuf ;fill the buffer
getcb1: ildb a,filbpt(b) ;;entry for wrdlts
move t,fillts(b) ;line number test bit
tdne t,@filbpt(b)
jrst getbln ;saw a line number
andi a,177
jumpe a,getchb ;ignore nulls
move a,@filcht(b)
hlrem a,fileol(b)
hrrzm a,filcmp(b)
came a,[xwd -1," "] ;CR is standard Pascal mode
popj p,
jrst geteol ;get "real" EOLN
getbln: move t,@filbpt(b)
movem t,fillnr(b)
aos filbpt(b)
movni t,5
addb t,filbct(b)
jumpge t,getchb
pushj p,reabuf
ibp filbpt(b)
jrst getchb
subttl buffered I/O - buffer advance routines
wrtbuf: push p,c ;write the buffer
push p,b
hrrz a,filjfn(b)
movn c,filpbs(b)
move b,filpbp(b)
skipe c ;[40] zero is special
sout
chkquo
erjmp ioebcp
pop p,b
move a,filbfs(b) ;reinitialize state
subi a,1 ;sos already done
movem a,filbct(b)
move a,filbfp(b)
movem a,filbpt(b)
pop p,c
popj p,
ioebcp: pop p,b
ioecp: pop p,c
adjstk p,-1 ;abort caller
jrst ioerp
reabuf: skipe filter(b) ;fill the buffer - delayed error?
jrst simerx ;yes - pretend it happened now
push p,c
push p,b
hrrz a,filjfn(b)
movn c,filpbs(b)
move b,filpbp(b)
sin
erjmp saverr ;store error for later
pop p,b
move a,filbfs(b)
subi a,1
movem a,filbct(b)
move a,filbfp(b)
movem a,filbpt(b)
pop p,c
popj p,
;We have to delay errors and activate them after the user has seen any
; characters that have been returned. Otherwise EOF would come too
; soon. Note that the code assumes (implicitly) that reabuf returns
; something. So if no bytes have been gotten at all, we have to do
; the error now - can't delay it.
saverr: pop p,b
move t,filbfs(b) ;t _ logical bytes per transfer byte
idiv t,filpbs(b)
imul c,t ;c _ - logical bytes not transferred
add c,filbfs(b) ;c _ bytes transferrred
jumpe c,ioecp ;[27] none - immediate error
subi c,1 ;caller has done sos
movem c,filbct(b)
move a,filbfp(b)
movem a,filbpt(b) ;otherwise normal init.
movei a,400000 ;save error code for simerr
move c,b ;save b ever jsys
geter
exch b,c ;c _ error code, fcb back in b
hrrzm c,filter(b)
pop p,c
popj p,
simerx: adjstk p,-1 ;abort caller
simerr: move t,filter(b) ;activate delayed error
movem t,filerr(b) ;put in real error place
setzm filter(b) ;not delayed anymore
jrst ioerpx ;and pretend we just saw it
subttl buffered I/O - open and close
logopn: trne g,of%rd ;common openning
trnn g,of%wr ;if read and write, can't do it
jrst .+2 ;only one, OK
jrst illfn
movei t,illfn ;make wrong direction illegal (or he
skprea ;writing? (might not get the error
movem t,filget(b) ;read illegal (until fnished the
skpwrt ;reading? (buffer)
movem t,filput(b)
ldb a,[fl%buf!filflg(b)] ;number of buffers user wants
caig a,0 ;must be between 1 and 36
movei a,1 ;if 0, use default
caile a,^D36 ;if too big, use maximum
movei a,^D36
move t,a ;now have pages per buffer - get words
lsh t,^D9 ;t _ words in buffer
movem t,filpbs(b) ;filpbs _ words in buffer
;caller may reset this to bytes in buffer if that is what he wants
pushj p,alcbuf ;# pages is arg to alcbuf, in A
ldb t,[point 6,g,5] ;logical byte size
lsh t,^D24 ;make byte pointer
tlo t,440000 ;to beginning of word
hrr t,filbuf(b) ;at buffer
movem t,filbfp(b) ;store as logical bufer start
setzm filbpt(b) ;assume nothing in buffer
skprea ;if writing, give a full buffer
movem t,filbpt(b)
movei t,^D36
ldb a,[point 6,g,5] ;computer buffer size in bytes
idiv t,a ;t _ bytes per word
imul t,filpbs(b) ;t _ bytes in buffer
movem t,filbfs(b) ;store as logical size
setzm filbct(b)
skprea ;if writing, give a full buffer
movem t,filbct(b)
setzm filter(b)
setzm fillct(b)
popj p,
chropn: skipe filerr(b) ;byte mode I/O open
popj p, ;no-op if error
pushj p,openfi
chrop1: pushj p,logopn ;compute logical parameters
move t,filbfp(b) ;physical param's = logical ones
movem t,filpbp(b)
move t,filbfs(b)
movem t,filpbs(b)
popj p,
wrdopn: skipe filerr(b) ;word mode I/O open
popj p,
pushj p,logopn
move t,filbuf(b) ;physical param's use 36 bit bytes
hrli t,444400
movem t,filpbp(b)
tlz g,770000
tlo g,440000 ;set 36 bit bytes
;filpbs is left as set by logopn - words in buffer
jrst openfi
ifn srisw,< ;[23]
;This is part of the SRI kludge. See DSKLTS for an explanation of the
; reason for the kludge.
;device-dependent code to examine the first word to see if line-numbered.
; This code is mainly for the use of magtape. Since it is fairly common
; there to open the file, set parameters, and then do the first read, we
; have to wait and do the actual test at the first read. Thus this routine
; temporarily changes FILGET to call a routine that tests the first
; word, restores FILGET to the right thing, and then calls it. For the
; disk we have to do the actual test at open time, because somebody might
; do SETPOS before the first real. But for disk it is safe because one
; can do the test without any sideeffects. We tried BIN then BKJFN, but
; due to a monitor bug that doesn't work for tape.
wrdlts: movei t,wrdgtt ;[22] special get that does a test first
movem t,filget(b) ;[22] booby-trap FILGET
popj p,
;[22] Special routine called for the first GETCH on the file, to see if line
;[22] numbered. The order in which things are done in this routine is a bit
;[22] more critical than it looks, in order to make error handling work.
wrdgtt: movei t,getchb ;[22] restore normal reader
movem t,filget(b) ;[22]
pushj p,reabuf ;[22] get first buffer in
move a,filbpt(b) ;[22] pointer to first byte
ibp a ;[22] but expected to do ILDB
move t,(a) ;[22] now have first word of buffer
push p,c ;[22] comlts uses t,a,c,d
push p,d ;[22]
pushj p,comlts ;[22]
pop p,d ;[22]
pop p,c ;[22]
jrst getcb1 ;[22] now continue with normal code
> ;[23] ifn srisw
logclo: skpwrt ;force buffers
popj p, ;reading - none
move t,filbpt(b) ;zero rest of last word
;magic code to clear rest of word. The offset field in the byte
; ponter now continas no. of bits from the right to be clered,
; so we use a new byte ptr with no offset and this as the size.
tlz t,007700
hllz a,t
lsh a,-6
hll t,a
setz a, ;cler them
dpb a,t
move t,filbfs(b) ;compute no. of bytes to put out
idiv t,filpbs(b) ;t _ bytes / transfer byte
move a,t ;a _ bytes / transfer byte
move t,filbfs(b) ;t _ bytes used
sub t,filbct(b) ;t _ bytes remaining
jumpe t,cpopj ;if none - done
idiv t,a ;t _ transfer bytes remaining
skipe a ;round up
addi t,1
push p,c
push p,b
movn c,t ;make sin arg block
hrrz a,filjfn(b)
move b,filpbp(b)
skipe c ;[40] zero is special
sout
chkquo
erjmp ioebcp ;abort caller
pop p,b
pop p,c
move t,filbfp(b) ;set up to make more possible
movem t,filbpt(b)
move t,filbfs(b)
movem t,filbct(b)
popj p,
setpb: pushj p,logclo ;setpos (curpos is curpbx)
pushj p,logini
jrst setpbx
logini: skprea ;breakin
popj p, ;no-op on write
setzm filbct(b)
setzm fillct(b)
skipe filter(b) ;if saved error
pushj p,simerr ;activate it
popj p,
subttl buffered I/O - routines for record I/O
;The following routines set up C to indicate the desired
; transfer, and then call getblp or putblp, which simulate
; sin and sout. If an I/O error occurs, getblp or putblp
; will return with c as at the point of error. Thus the
; caller may have some adjustments to do.
;get
getb: movem c,fillct(b) ;assume no. transferred = no. requested
movn c,c ;make up aobjn word
hrl c,c ;lh(c) _ no. to transfer
hrri c,filcmp(b) ;rh(c) _ starting loc to transfer
pushj p,getblp ;sin
hlre c,c ;c _ - no. left untransferred
addm c,fillct(b) ;adjust assumption
popj p,
;put
putb: movem c,fillct(b)
movn c,c
hrl c,c
hrri c,filcmp(b)
pushj p,putblp ;sout
hlre c,c
addm c,fillct(b)
popj p,
;getx
getxb: move d,c ;requested upper limit
sub c,fillct(b) ;c _ no. needed this time
movn c,c ;make aobjn word
hrl c,c
hrri c,filcmp(b)
add c,fillct(b) ;adjust by no. already done
pushj p,getblp ;sin
hlre c,c
addm c,fillct(b)
popj p,
;Here are the sin/sout simulations. Note that if there is
; en I/O error, ioebcp will abort the routine.
; In that case c will be left negative, and the caller (above)
; will do the right thing.
;sin
getblp: sosge filbct(b) ;sin simulation
pushj p,reabuf
ildb a,filbpt(b)
movem a,(c)
aobjn c,getblp
popj p,
;sout
putblp: sosge filbct(b) ;sout simulation
pushj p,wrtbuf
move a,(c)
idpb a,filbpt(b)
aobjn c,putblp
popj p,
subttl initialization
pasin.: jsp a,pasif. ;[6] for old programs, new ones use pasif.
popj p, ;[6]
pasif.: move g,a ;[6] save return address
move f,b ;save flag for checking
hlrz e,.jbsa## ;get 1st above low seg
subi e,1 ;adjust to page boundary
tro e,777 ;we assume .jbff is always even page
addi e,1
hrlm e,.jbsa ;and put back adjusted value
clrlop: caml e,.jbff## ;now clear everything up to .jbff
jrst clrdon
seto a, ;unmap the page
move b,e
lsh b,-9 ;make page no.
hrli b,400000 ;this process
setz c,
pmap
addi e,1000 ;now go to next page
jrst clrlop
clrdon: hlrz e,.jbsa ;get back adjusted top of code
movem e,.jbff ;use for .jbff
reset
setzm izer1 ;zero interrupt data area
move t,[xwd izer1,izer1+1]
blt t,izer99
setzm chntb. ;reinitialize interrupt control blocks
move t,[xwd chntb.,chntb.+1]
blt t,chntb.+^D35
move t,[xwd 1,ovrflw]
movem t,chntb.+6
movem t,chntb.+7
move t,[xwd 1,pdltrp]
movem t,chntb.+^D9
movei a,400000 ;turn on interrupts
move b,[xwd levtab,chntb.]
sir ;set up vector
movsi b,(1b9) ;[4] pdl overflow
skipe f ;[4] ignore arith. if not checking
tlo b,(1b6!1b7) ;[4] arith. overflow
aic ;turn on conditions
eir ;turn on system
;if any files are left open, we clear filtst, to indicate that they
;need reinitialization
movei a,blktab ;loop through all files
pasin1: skipe b,(a) ;get the fcb addr there
setzm filtst(b) ;and indicate no longer valid
setzm (a) ;clear table entry
camge a,lstblk ;go to next, if any
aoja a,pasin1
setzm lstblk ;now nothing in use
setom blklck ;restore all to unlocked
move a,[xwd blklck,blklck+1]
blt a,blklck+blklen-1
;here we are going to set the frepag bit table to all 1's to indicate all
; pages are free. GETPG. checks for overlap with heap, which is below
; the code, so we won't run into the high seg. After setting to all 1's,
; we then remove pages below .jbff, i.e. the low seg.
pasin2: setom frepag ;indicate all 512 pages free
move t,[xwd frepag,frepag+1]
blt t,frepag+15 ;clear 14 words
movsi t,776000 ;and 10 bits
movem t,frepag+16
move b,.jbff## ;now clear everything below .JBFF
lsh b,-11 ;get page number. b is # of pages to be clear
idivi b,44 ;b _ words to be cleared, c _ bits
sojl b,pasin3 ;no words, just do bits
setzm frepag ;b _ words-1 to be cleared
jumpe b,pasin3 ;one word only, do bits
move t,[xwd frepag,frepag+1]
blt t,frepag(b) ;clear words
;all full words cleared, b _ # words cleared - 1
pasin3: jumpe c,pasin4 ;if no bits to clear, ignore
movsi t,400000 ;make mask for c bits
movn c,c
ash t,1(c) ;t _ xxx000, c bits on
andcam t,frepag+1(b) ;clear these bits in next word
pasin4: setzm tty##+1
setzm tty##+filbct
move t,[xwd tty##+1,tty##+2]
blt t,tty##+filr11-1
setzm ttyout##+1
move t,[xwd ttyout##+1,ttyout##+2]
blt t,ttyout##+filr11-1
move t,[xwd ttynt,tty##+filr11] ;copy special tty routines into tty
blt t,tty##+filr99
move t,[xwd ttynt,ttyout##+filr11] ;and ttyout
blt t,ttyout##+filr99
aos tty##+fileol
aos tty##+filbad
aos ttyout##+fileof
move t,[ascii /-----/]
movem t,tty##+fillnr
movem t,ttyout##+fillnr
movei t,ttybuf
movem t,tty##+filttb
movei t,314157 ;magic indicating a valid file
movem t,tty##+filtst
movem t,ttyout##+filtst
SETZM AVAIL##
SETZM AVAIL+1
SETZM BEGMEM##
SETZM ENDMEM##
jrst (g) ;[6] return
reloc
blklen==140 ;there are only 100 jfn's possible
blklck: block blklen
blktab: block blklen
lstblk: block 1
;still in low segment
subttl error trapping
;still in low segment
intern chntb.,oldpc.
levtab: .+3
.+3
.+3
oldpc.: block 3
chntb.: block 6 ;0 - 5
xwd 1,ovrflw ;6
xwd 1,ovrflw ;7
block 1 ;[4] 8
xwd 1,pdltrp ;[4] 9
block ^D32 ;[4] 10-35
reloc
ovrflw: ;This routine is taken from forots, more or less
fxu==1b11 ;floating underflow
fov==1b3 ;some floating pt. error
ndv==1b12 ;some division by zero
adjstk p,3 ;[3] just for safety, as sometimes use above stack
push p,t ;[3] save ac's so we can restore
push p,a ;[3]
move t,oldpc.
hrrz a,t ;the error pc
cail a,safbeg## ;in runtime
caile a,safend##
jrst .+2
jrst ignore
camge n,.jbff## ;in debugger
jrst ignore
hlrz a,t ;get flags in RH
andi a,(ndv!fov!fxu) ;clear all but these
lsh a,-5 ;right-justify ndv
trze a,(1b8) ;fov set?
iori a,1b33 ;move it to right end
hrro a,aprtab(a) ;get right error message
esout
pushj p,runer. ;put out pc and maybe go to ddt
; jrst ignore ;if he continues, ignore the error
ignore: pop p,a ;[3] restore state and exit
pop p,t ;[3]
adjstk p,-3 ;[3]
debrk
aprtab: [asciz /Integer overflow/]
[asciz /Integer divide check/]
[0]
[0]
[asciz /Floating overflow/]
[asciz /Floating divide check/]
[asciz /Floating underflow/]
[0]
pdltrp: move p,[xwd 20,20] ;[4] fake pdl - real one is garbage
hrroi a,[asciz /No space left for stack or local variables/] ;[4]
esout ;[4]
move t,oldpc. ;[4]
pushj p,runer. ;[4] pasddt has its own stack
hrroi a,[asciz /Can't continue without stack
/]
psout
jrst endl
subttl critical sections
intern lockc.,level.,leav.
entry enterc,leavec
reloc
izer1:
level.: block 1 ;current interrupt level
lockc.: block 1 ;0 or pointer to int. deferral block if in crit. section
dfins0: block 1 ;interrupt deferral blocks:
dfins1: block 1
dfins2: block 1
dfins3: block 1
izer99==.-1
reloc
dftab: dfins0
dfins1
dfins2
dfins3
enterc: move a,level. ;set up int. deferral block
move a,dftab(a)
movem a,lockc. ;now in critical section
popj p,
leavec: movei a,0
exch a,lockc. ;out of critical section
skipe a ;user is doing leave without enter
skipn (a) ;any deferred interrupt?
popj p, ;no - normal exit
push p,b
move b,(a) ;deferred interrupts
setzm (a) ;zero for next use
movei a,400000 ;this job
iic
leav.: pop p,b
popj p,
subttl page allocation/deallcation
entry getpag,relpag ;[20]
;getpg.
; a - count of number of pages desired
;garbages a,t - result in a
getpg.: push p,lockc. ;remember if user was in crit. sec.
push p,a
skipn lockc. ;if so, don't make new one
pushj p,enterc ;critical section
pop p,a
push p,b
push p,c
push p,d
push p,e
push p,f
;here we set up pagmsk to be xxxx0000, with x being (a) bits
caile a,44 ;be sure count is legal
jrst getptm ;too many
movsi b,400000 ;b _ 400000,,0
movn c,a
ash b,1(c) ;b _ xxx0000, as ash propogates the bit
pagmsk==0 ;location of mask on stack
push p,b
hrlzi b,-17 ;b - aobjn pointer to word we are looking at
move d,a ;d - number of pages desired
;outer loop in which we check all words i
getpl1: move t,frepag(b) ;first find a word in which there are free
movei c,0 ;c - accumulate previous shifts
;inner loop in which we check various starting places in word
;Note that t gets shifted if we have to retry this
getpl2: jffo t,gotbit ;if free page in this word, exit search
aobjn b,getpl1 ;no more bits in this word, get next
jrst nofree ;ran out of words, we failed
;here is the text of the inner loop
;we have found one free page, see if we have N contiguous ones
gotbit: add c,a ;c _ total shift to this bit
setcm e,frepag(b) ;e,f _ complement of words being tested
setcm f,frepag+1(b)
lshc e,(c) ; shifted to left justify tested bits
tdnn e,pagmsk(p) ;since complemented, if all are zero
jrst gotpgs ;then we have our pages
;not enough bits after the one we found. We now shift the word (in t)
;to the beginning of the field we were considering plus one more bit.
;this eliminates the bit our last jffo found, and causes the next one
;to advance to the next bit. However it requires us to keep track of
;the total amount of shifting, which is done in c.
lsh t,1(a) ;get to start of field, and gobble one bit
addi c,1 ;indicated shifted by one more
jrst getpl2 ;and see if another candidate in this word
;here when we have found the free pages
;clear the bits in frepag array and figure out page number
gotpgs: move e,pagmsk(p) ;get mask for clearing
setz f,
movn a,c ;a _ neg no. of bits shifted
lshc e,(a) ;e,f _ mask of bits found
andcam e,frepag(b) ;clear bits in memory
andcam f,frepag+1(b)
tlz b,-1 ;now compute b _ page number
imuli b,44 ;words times pages in a word
add b,c ;and offset within word
lsh b,11 ;d _ addr of first page in group
move c,d ;c _ number of pages in group
lsh c,11 ;c _ number of words in group
add c,b ;c _ first address beyond
caml c,lstnew ;be sure we don't overlap heap
jrst nofree ;if we do, fatal error
camle c,.jbff## ;if we have taken more core
movem c,.jbff## ; update .jbff
move a,b ;a _ address of first page in group
hrl a,d ;number of pages in LH
pop p,(p) ;pagmsk
pop p,f ;saved ac's
pop p,e
pop p,d
pop p,c
pop p,b ;previous lock still on stack
push p,a ;stack is top --> ret val , lock
getpgx: skipn -1(p) ;if user was in cri. sec., don't leave
pushj p,leavec ;end critical section
pop p,a
pop p,(p)
popj p,
getptm: hrroi a,[asciz /Internal error: buffer request exceeds 36 pages/]
esout
jrst endl
nofree: hrroi a,[asciz /Request for buffer space runs into heap /]
esout
jrst endl
;relpg.
; a - count,,addr
;garbages a,t - arg in a
relpg.: push p,lockc. ;remember whether user was in crit. sec.
push p,a
push p,b
push p,c
skipn lockc. ;if so, don't make new one
pushj p,enterc ;critical section
movsi t,400000 ;t,a _ 400000...
setz a,
hlrz b,-2(p) ;number of pages
caile b,44 ;be sure its legal
jrst getptm
movn b,b ;b _ - number of pages
ash t,1(b) ;t,a _ xxx000 with one x for each page
hrrz b,-2(p) ;addr to return
lsh b,-11 ;make into page number
idivi b,44 ;b _ word offset, c _ bit within word
movn c,c ;c _ - number of bits
lshc t,(c) ;t,a _ mask of bits to set in word
iorm t,frepag(b) ;clear at offset b and b+1
iorm a,frepag+1(b)
pop p,c
pop p,b
pop p,a
pop p,t
skipn t ;if user was in cri. sec., don't leave
jrst leavec ;end critical section
popj p,
;[20] Replaced old routines that did only one page.
;Routines for normal user use
;procedure getpages(howmany:integer;var pagenum:integer; var:page:^realpage);
;b - number of pages to get
;c - place to put page no.:
;d - place to put addr.
getpag: move a,b ;number of pages
pushj p,getpg. ;actually get page - addr in a
hrrzm a,(d) ;return addr
tlz a,777777 ;clear out LH (count)
lsh a,-9 ;return page no.
movem a,(c)
popj p,
;procedure relpages(howmany:integer;pagenum:integer);
;b - number of pages to return
;c - page to return
relpag: caile b,0 ;check args - count GT 0
caig c,0 ;page number GT 0
jrst illpag
move d,c
add d,b ;page + count LE 1000
caile b,1000
jrst illpag
lsh c,9 ;make addr
move a,c ;where rlpag wants it
hrl a,b ;number to return
jrst relpg.
illpag: hrroi a,[asciz /Relpages: page numbers must be 1 to 777B
/]
esout
jrst endl
if2,< purge sin> ;so we don't interfere with Forlib's sin
prgend
TITLE NEW ; FAKE ENTRY IN CASE DISPOSE NOT INCLUDED
SEARCH PASUNV
ENTRY NEW
NEW=GETNEW##
TWOSEG
RELOC 0
AVAIL:: BLOCK 2
BEGMEM::BLOCK 1
ENDMEM::BLOCK 1
RELOC 400000
PRGEND
title DANGER - routine for dummy label when pasnum not loaded
entry safbeg,safend
safbeg: block 0
safend: block 0
end