;;;-*-Midas-*-

title KSFEDR - Manipulate KS-10 front end filesystem under timesharing

nfifls==:0			; Number of FI files.
				; (Feature doesn't work)

a=:1
b=:2
c=:3
d=:4
e=:5
t=:6
tt=:7

p=:17

ttyich==:1
ttyoch==:2
echoch==:3
dskich==:4
dskoch==:5
errich==:7
fsch==:8

call=:pushj p,
return=:popj p,
save=:push p,
rest=:pop p,
tyi=:.iot ttyich,
tyo=:.iot ttyoch,
pause=:.break 16,100000

define syscall name,args
	.call [setz ? sixbit /name/ ? args(400000)]
termin

define conc foo,bar
foo!bar!termin

;;; Grok the KS10:
.insrt dsk:system;ksdefs

;;; Grok the ITS filesystem:
.insrt dsk:system;fsdefs

;;; The FE filesystem under ITS lives in a single file named something like
;;; DSK:.;.FEFS. PK0001, where PK0001 is the pack number that contains the
;;; file.  The format of the file is set forth at the end of this file.

;;; To create a new FE filesystem, give the CREATE command to KSFEDR.
;;; KSFEDR will then search the pack on the drive you specify for a
;;; suitable location.  (If the pack is mostly empty, this shouldn't take
;;; long.)
;;;
;;; When it has created the file, KSFEDR will tell you the "Directory
;;; address" of the new FE filesystem.  This is the absolute disk address
;;; that the 8080 front end needs in order to find the FE filesystem.
;;; KSFEDR gives you this address as a 36-bit quantity in the format the
;;; 8080 uses.  There is a routine in the salvager called FESET that knows
;;; how to install this address on the disk where the 8080 will find it.
;;;
;;; Before taking ITS down to run FESET, you will probably want to use the
;;; WRITE command in KSFEDR to put a microcode into the FE file named "RAM"
;;; and a DSKDMP bootstrap into the FE file named "BT".  It is also
;;; recommended that a suitably nasty message be placed in the FE file
;;; named "README", so that people will know that playing with the FE
;;; filesystem file under timesharing is a no-no.

popj1:	aos (p)
cpopj:	return

rfn"$$rfn==:1
rfn"$$pfn==:1
.insrt dsk:syseng;rfn

rsixtp==:cpopj
psixtp==:cpopj

;;;RFN"RFN
;;; A (val): terminating character
;;; B (arg, val): filename block
;;; D (arg, val): byte pointer
;;; E (val): 3.4 - 3.1 indicate names specified

format"$$pfn==:1
format"pfn=:rfn"pfn
format"$$pcode==:1
format"$$errs==:1
format"erri==:errich
.insrt dsk:syseng;format

outstr:	syscall siot,[movei ttyoch ? a ? b]
	 .lose %lssys
	return

define format &string&,[args]
	pushj p,[
	pushj p,fmtin
zzz==-1
irp arg,,args
	push p,arg
zzz==.irpcnt
termin
	hrroi a,[ascii string]
	movei b,.length string
	movni c,zzz+1
	jrst format"format]
termin

fmtin:	push p,a
	push p,b
	push p,c
	push p,[fmtout]
	jrst @-4(p)

fmtout:	pop p,c
	pop p,b
	pop p,a
	pop p,(p)
	popj p,

lpdl==:100.
.vector pdl(lpdl)

go:	.core fspage
	 .lose
	move p,[-lpdl,,pdl-1]
	.open ttyich,[.uai,,'tty ? setz ? setz]
	 .lose
	.open ttyoch,[.uao+%tjdis,,'tty ? setz ? setz]
	 .lose
	.open echoch,[.uao,,'tty ? setz ? setz]
	 .lose
irps sym,,[secblk,nblks,nblksc,nsecs]param,,[sec%bl,bl%dsk,bl%cyl,sec%tr]
	move tt,[squoze 0,sym]
	.eval tt,
	 .lose
	movem tt,param
termin
	movei tt,2000
	idiv tt,sec%bl
	movem tt,wd%sec
	move tt,[squoze 0,QPKID]
	.eval tt,
	 .lose
	hrlzi tt,(tt)
	hrri tt,fspak		; Pack number of pack on unit #0
	.getloc tt,
	call setpak
	jrst check		; Do automatic check-out first thing.

abort:	move p,[-lpdl,,pdl-1]
	format "~&(Abort)"
	jrst cmdlp

eh:	format "~&?Eh"
cmdlp:	movei a,[
	  tyo [^P]
	  tyo ["A]
	  tyo ["!]
	  return]
	call token
	 jrst eh
	jrst docmd

.vector fname(4)
.scalar arg

cmds:	check,,[asciz "Check correctness of FE filesystem"]
	create,,[asciz "Create a new FE filesystem from scratch"]
	help,,[asciz "List commands"]
	pack,,[asciz "Select pack"]
	quit,,[asciz "Return to superior"]
	read,,[asciz "Read a file from FE filesystem"]
	write,,[asciz "Write a file into the FE filesystem"]
ncmds==:.-cmds

cmdnam:	sixbit /check/
	sixbit /create/
	sixbit /help/
	sixbit /pack/
	sixbit /quit/
	sixbit /read/
	sixbit /write/
ifn .-cmdnam-ncmds, .err CMDNAM wrong length.

docmd:	movsi b,-ncmds
	came a,cmdnam(b)
	 aobjn b,.-1
	jumpge b,eh
	hlrz t,cmds(b)
	jrst (t)

quit:	.logout 1,

help:	format "~&KSFEDR commands:"
	movsi a,-ncmds
helplp:	hrro t,cmds(a)
	format "~& ~S	~A",[cmdnam(a),t]
	aobjn a,helplp
	jrst cmdlp

pack:	move a,[format "~&Select which pack? "]
	call number
	 jrst pack
	cail a,10000
	 jrst pack
	movem a,fspak
	call setpak
	jrst check		; Check it out

create:	call mapin
	 jrst [	cain e,%ensfl
		 jrst creat1
		syscall lose,[movei %lssys(e) ? movei create]
		 .lose %lssys ]
	.close fsch,
	format "~&ERROR:  File already exists."
	jrst cmdlp

creat1:	setzm bigbuf
	move tt,[bigbuf,,bigbuf+1]
	blt tt,bigbuf+1777
creat4:	syscall open,[[.bio,,fsch] ? fsdev ? fsfn1 ? fsfn2 ? fsdir]
	 .lose %lsfil
	movei t,fslen
creat2:	move tt,[-2000,,bigbuf]
	.iot fsch,tt
	sojg t,creat2
	syscall finish,[movei fsch]
	 .lose %lssys
	call mapin
	 .lose %lssys(e)
	call proper
	 jrst [	syscall delewo,[movei fsch]
		 .lose %lssys
		jrst creat4 ]
	call herald
	movsi e,-nptrs
creat5:	hrrz a,ptrs(e)
	subi a,fsbase
	call qaddr
	hlrz b,ptrs(e)
	movem a,(b)
	aobjn e,creat5
	call finish
	jrst cmdlp

herald:	save a
	movei tt,trunam
	format "~&FE filesystem ~F on pack #~D.",[tt,trupak]
	movei a,dir-fsbase
	call qaddr
	format "~&Directory address: ~O",a
	rest a
	return

finish:	syscall dskupd,[movei fsch]
	 .lose %lssys
	syscall sreapb,[movei fsch ? movei 1]
	 .lose %lssys
	move t,trulen
	jrst finsh1

finsh2:	syscall pgwrit,[movei fspage(t)]
	 .lose %lssys
finsh1:	sojge t,finsh2
	return

.scalar fspak			; Intended pack number

; CALL SETPAK:  Set pack from FSPAK
setpak:	save a
	save b
	move a,fspak
	move b,[sixbit /PK0000/]
	call devnum
	movem b,fsdev
	movem b,fsfn2
	rest b
	rest a
	return

.vector ufd(2000)

lblknum==:100.
.vector blknum(lblknum)

.vector trunam(4)
.scalar trupak
.scalar trulen			; In blocks.

;;;CALL MAPIN:  Map in the FE filesystem.
;;; Skips if everything OK, else returns error code in E.
;;; Sets up BLKNUM, TRUNAM, TRUPAK, and TRULEN.
;;; Leaves FSCH open.
mapin:	syscall open,[[.bii,,fsch] ? moves e ? fsdev ? fsfn1 ? fsfn2 ? fsdir]
	 return
	syscall open,[[.bii,,dskich] ? fsdev ? [sixbit /.file./]
			[sixbit /(dir)/] ? fsdir]
	 .lose %lsfil
	move t,[-2000,,ufd]
	.iot dskich,t
	.close dskich,
	syscall fillen,[movei fsch ? movem t]
	 .lose %lssys
	addi t,1777
	lsh t,-12
	cail t,fslen
	 caile t,lblknum
	  jrst [ movei e,%ebdfl ? return ]
	movem t,trulen
	movn t,t
	hrlz t,t
	hrri t,fspage
	syscall corblk,[movei %cbndr+%cbndw ? movei %jself ? t ? movei fsch]
	 .lose %lssys
	movei tt,trunam
	syscall rfname,[movei fsch ? movem 0(tt) ? movem 1(tt)
			movem 2(tt) ? movem 3(tt)]
	 .lose %lssys
	syscall filblk,[movei fsch ? movem t ? movem t ? movem t]
	 .lose %lssys
	ldb tt,[unpkn t]
	movem tt,trupak

	aos (p)			; Everything is cool from here on in.
	save b
	save c
	save d
	ldb b,[undscp t]
ifn ufdbyt-6, .err Somebody changed UFDBYT!
	idivi b,6
	add b,(c)[		; B: descriptor byte pointer
		440600,,ufd+uddesc
		360600,,ufd+uddesc
		300600,,ufd+uddesc
		220600,,ufd+uddesc
		140600,,ufd+uddesc
		060600,,ufd+uddesc]
	setoi c,		; C: last block number
	setzi d,		; D: index into BLKNUM
nxtblk:	ildb t,b
	jumpe t,mapinx
	caig t,udtkmx
	 jrst taket
	caige t,udwph
	 jrst skipt
	caig t,udwph
	 jrst nxtblk
	setzi c,
	;; 8/19/90 DM "funny" bit officially flushed.  We now take 5 bits
	;; from the first byte.
	dpb t,[<<060000*nxlbyt>+000500>,,c]
repeat nxlbyt,[
	ildb t,b
	dpb t,[<<060000*<nxlbyt-1-.rpcnt>>+000600>,,c]
	]
take1:	movem c,blknum(d)
	aos c
	aoja d,nxtblk

taket:	skipge c
	 .lose			; Shouldn't happen
taket0:	movem c,blknum(d)
	aos c
	aos d
	sojg t,taket0
	jrst nxtblk

skipt:	skipge c
	 .lose			; Shouldn't happen
	addi c,-udtkmx(t)
	jrst take1

mapinx:	rest d
	rest c
	rest b
	return

;;;CALL PROPER:  Skips if microcode blocks are proper.
proper:	move t,blknum+ramblk
	move tt,[1-ramlen,,ramblk+1]
propr1:	aos t
	camn t,blknum(tt)
	 aobjn tt,propr1
	jumpl tt,cpopj
	save a
	save b
	move a,blknum+ramblk
	call qaddr1
	ldb b,[$88cyl a]
	move a,blknum+ramblk+ramlen-1
	call qaddr1
	ldb a,[$88cyl a]
	camn a,b
	 aos -2(p)
	rest b
	rest a
	return

check:	call mapin
	 jrst [	movei tt,fsblk
		format "~&ERROR:  ~:@E:  ~F",[e,tt]
		jrst cmdlp ]
	call herald
	move tt,fspak
	came tt,trupak
	 format "~&WARNING:  This filesystem lives on pack #~D, not pack #~D as expected.",[trupak,fspak]
	call proper
	 format "~&WARNING:  Microcode blocks are not properly positioned."
	movsi e,-nptrs
check5:	hrrz a,ptrs(e)
	subi a,fsbase
	call qaddr
	move c,a
	hlrz b,ptrs(e)
	hrro a,ptrtxt(e)
	call corect
	aobjn e,check5
	jrst cmdlp

ptrs:	ramptr,,ram
	btptr,,bt
	bt1ptr,,bt1
	b2ptr,,b2
repeat nfifls, conc fi,\.rpcnt,ptr,,conc fi,\.rpcnt
nptrs==:.-ptrs

ptrtxt:	[asciz "Bad microcode pointer"]
	[asciz "Bad bootstrap (BT) pointer"]
	[asciz "Bad bootstrap (BT1) pointer"]
	[asciz "Bad bootstrap (B2) pointer"]
repeat nfifls,[
	[conc asciz "Bad indirect file (FI,\.rpcnt,) pointer"]
	]
ifn .-ptrtxt-nptrs, .err PTRTXT wrong length.

corect:	camn c,(b)
	 return
	format "~&WARNING:  ~A.",a
	move a,[format "~&  Clobber it? "]
	call yesnop
	 return
	movem c,(b)
	jrst finish

.scalar sec%bl			; # sectors per block
.scalar wd%sec			; # words per sector (2000/SEC%BL)
.scalar bl%dsk			; # blocks per disk
.scalar bl%cyl			; # blocks per cylinder
.scalar sec%tr			; # sectors per track

;;;QADDR:  Compute physical disk address from file address
;;; A (arg): file address
;;; A (val): FE format disk address of that sector
qaddr:	save b
	save c
	idivi a,2000		; A: file block #
	idiv b,wd%sec		; B: block sector #
	skipe c
	 .lose			; Not a sector address?
	move t,blknum(a)	; T: disk block #
	caml t,bl%dsk
	 .lose			; Block # too big?
	setzi a,
	idiv t,bl%cyl
	dpb t,[$88cyl a]
	imul tt,sec%bl
	add b,tt		; B: cylinder sector #
	idiv b,sec%tr
	dpb b,[$88trk a]
	dpb c,[$88sec a]
	rest c
	rest b
	return

;;;QADDR1:  Compute physical disk address from disk block #
;;; A (arg): disk block #
;;; A (val): FE format disk address of first sector of that block
qaddr1:	move t,a
	caml t,bl%dsk
	 .lose			; Block # too big?
	setzi a,
	idiv t,bl%cyl
	dpb t,[$88cyl a]
	move t,tt
	imul t,sec%bl
	idiv t,sec%tr
	dpb t,[$88trk a]
	dpb tt,[$88sec a]
	return

files:	sixbit /readme/
	sixbit /ram/
	sixbit /bt/
	sixbit /bt1/
	sixbit /b2/
repeat nfifls, conc sixbit /fi,\.rpcnt,/
nfiles==:.-files

listem:	format "~&Existing files are:"
	movsi e,-nfiles
	format " ~S",files(e)
	 aobjn e,.-1
filidx:	move a,[format "~&Which file? "]
	call token
	 jrst listem
	movsi e,-nfiles
	came a,files(e)
	 aobjn e,.-1
	jumpge e,listem
	return

.vector iofile(4)

itstyp:	sixbit />/
	sixbit /RAM/
	sixbit /BIN/
	sixbit /BIN/
	sixbit /BIN/
repeat nfifls, sixbit />/
ifn .-itstyp-nfiles, .err ITSTYP wrong length.

gfname:	movsi tt,(sixbit /DSK/)
	movem tt,iofile+0
	movem a,iofile+1
	move tt,itstyp(e)
	movem tt,iofile+2
	.suset [.rsname,,iofile+3]
	move a,b
	movei b,iofile
	jrst readfn

define dfhckr loc,type
	[movei d,loc ? jrst rd!type],,[movei d,loc ? jrst wr!type]
termin

hacker:
dfhckr readme,txt
dfhckr ram,ram
dfhckr bt,bt
dfhckr bt1,bt
dfhckr b2,bt
repeat nfifls, conc dfhckr fi,\.rpcnt,,fi
ifn .-hacker-nfiles, .err HACKER wrong length.

read:	call filidx
	move b,[format "~&Output to"]
	call gfname
	hlrz t,hacker(e)
	jrst (t)

write:	move a,[
	  format "~&Are you sure you want to scribble in the FE filesystem? "]
	call yesnop
	 jrst cmdlp
	call filidx
	move b,[format "~&Input from"]
	call gfname
	hrrz t,hacker(e)
	jrst (t)

rdram:	movei c,<ramlen_12> ? jrst rdimag
wrram:	movei c,<ramlen_12> ? jrst wrimag
rdtxt:
rdbt:	movei c,1000 ? jrst rdimag

rdimag:	syscall open,[[.bio,,dskoch] ? 0(b) ? [sixbit /_FEDR_/]
			[sixbit /OUTPUT/] ? 3(b)]
	 .lose %lsfil
	movn t,c
	hrl d,t
	.iot dskoch,d
oclose:	syscall renmwo,[movei dskoch ? 1(b) ? 2(b)]
	 .lose %lssys
	.close dskoch,
	jrst cmdlp

	ramlen==:6		; Duplicate definition (2 passes suck)
.vector bigbuf(ramlen_12)	; Microcode files are biggest

wrimag:	syscall open,[[.bii,,dskich] ? 0(b) ? 1(b) ? 2(b) ? 3(b)]
	 .lose %lsfil
	caile c,ramlen_12
	 .lose			; BIGBUF too small?
	movn t,c
	hrlz t,t
	hrri t,bigbuf
	.iot dskich,t
	jumpl t,[
	  format "~&ERROR:  File too small.  Nothing was written."
	  .close dskich,
	  jrst cmdlp]
	move t,[-1,,tt]
	.iot dskich,t
	jumpge t,[
	  format "~&ERROR:  File too large.  Nothing was written."
	  .close dskich,
	  jrst cmdlp]
	hrlzi t,bigbuf
	hrri t,(d)
	addi d,-1(c)
	blt t,(d)
	.close dskich,
	call finish
	jrst cmdlp

wrbt:	syscall open,[[.uii,,dskich] ? 0(b) ? 1(b) ? 2(b) ? 3(b)]
	 .lose %lsfil
wrbt1:	.iot dskich,a
	came a,[jrst 1]
	 jrst wrbt1
	setzm bigbuf
	move tt,[bigbuf,,bigbuf+1]
	blt tt,bigbuf+777
	move a,[ksrim,,bigbuf]
	blt a,bigbuf+lksrim-1
	hrli a,lksrim-1000
wrbt2:	.iot dskich,(a)
	aobjp a,wrbtov
	skipl b,-1(a)
	 jrst wrbtex
	move c,b
wrbt3:	.iot dskich,(a)
	rot c,1
	add c,(a)
	aobjp a,wrbtov
	aobjn b,wrbt3
	.iot dskich,(a)
	came c,(a)
	 jrst [
	  format "~&ERROR:  Checksum error.  Nothing was written."
	  .close dskich,
	  jrst cmdlp]
	aobjn a,wrbt2
wrbtov:	format "~&ERROR:  SBLK file too long.  Nothing was written."
	.close dskich,
	jrst cmdlp

wrbtex:	movem b,(a)
bltblk:	hrli d,bigbuf
	movei tt,777(d)
	blt d,(tt)
	.close dskich,
	call finish
	jrst cmdlp

ksrim:				; Think of this as read-in mode for the KS-10.
offset 1000-.			; 8080 plunks BT file down in location
				;  1000 and starts it there.
	setzb 17,2000		; Clear core to flush all that bad parity.
	dmove 1,rimblt		; 1: Below  &  2: Above
	blt 1,777		; Zero the 8080 area.
	blt 2,777677		; But don't clobber DSKDMP bootstrap.
rimacl::wrubr rimacs		; Now clear all ACs:  Select a block.
	movsi 16,-1100		; Decrement WRUBR argument for next time
	addm 16,rimacs
	setzi 0,		; Zero this block
	movei 17,1
	blt 17,17
	skipge rimacs		; All done?  (Leave block 0 selected.)
	 jrst rimacl
	movsi a,lksrim-1000	; A: aobjn into sblks
rimblk::skipl b,sblks(a)	; B: aobjn into memory (if not start address)
	 jrst (b)
	aobjp a,rimerr
	move c,b		; C: checksum so far
rimwrd::move d,sblks(a)
	aobjp a,rimerr
	movem d,(b)
	rot c,1
	add c,d
	aobjn b,rimwrd
	camn c,sblks(a)
	 aobjn a,rimblk
rimerr::jrst 4,.

rimblt::17,,20
	2000,,2001

rimacs::407700,,0

	jrst 1			; Look like ITS SBLK file if dumped out...

sblks::

offset 0
lksrim==:.-ksrim

rdfi:	syscall open,[[.uao,,dskoch] ? 0(b) ? [sixbit /_FEDR_/]
			[sixbit /OUTPUT/] ? 3(b)]
	 .lose %lsfil
	hrli d,-1000
	movei c,3
	jrst rdfi0

rdfilp:	.iot dskoch,a
	cain a,^M
	 .iot dskoch,[^J]
rdfi0:	ldb a,(c)[301000,,(d) ? 201000,,(d) ? 101000,,(d) ? 001000,,(d)]
	jumpe a,oclose
	sojge c,rdfilp
	movei c,3
	aobjn d,rdfilp
	format "~&ERROR:  Indirect file not terminated by a null.  ~
		Output file was not renamed."
	.close dskoch,
	jrst cmdlp

wrfi:	syscall open,[[.uai,,dskich] ? 0(b) ? 1(b) ? 2(b) ? 3(b)]
	 .lose %lsfil
	setzm bigbuf
	move tt,[bigbuf,,bigbuf+1]
	blt tt,bigbuf+777
	move e,[-1000,,bigbuf]
	movei c,3
	jrst wrfi0

wrfilp:	cain a,177		; Kludge to experiment with...
	 movei a,377
	caie a,^J
	 jsp t,wrfidp
wrfi0:	.iot dskich,a
	hrrz a,a
	caie a,^C
	 jrst wrfilp
	movei a,0
	jsp t,wrfidp
	hrlzi t,bigbuf
	hrri t,(d)
	blt t,777(d)
	.close dskich,
	call finish
	jrst cmdlp

wrfidp:	dpb a,(c)[301000,,(e) ? 201000,,(e) ? 101000,,(e) ? 001000,,(e)]
	sojge c,(t)
	movei c,3
	aobjn e,(t)
	format "~&ERROR:  Indirect file too large.  Nothing was written."
	.close dskich,
	jrst cmdlp

wrtxt:	move tt,[.byte 7 ? 3 ? 3 ? 3 ? 3 ? 3]
	movem tt,bigbuf
	move tt,[bigbuf,,bigbuf+1]
	blt tt,bigbuf+777
	syscall open,[[.bai,,dskich] ? 0(b) ? 1(b) ? 2(b) ? 3(b)]
	 .lose %lsfil
	move tt,[-1001,,bigbuf]
	.iot dskich,tt
	.close dskich,
	jumpl tt,bltblk
	format "~&ERROR:  File too long.  Nothing was written."
	jrst cmdlp

;;;CALL YESNOP:  Ask the user a yes or no question.
;;; A (arg): prompt routine
;;; +0: no
;;; +1: yes
yesnop:	save a
ysnop1:	call token
	 jrst insist
	camn a,[sixbit /YES/]
	 jrst yes
	camn a,[sixbit /NO/]
	 jrst no
insist:	format "~&YES or NO"
	move a,(p)
	jrst ysnop1

yes:	aos -1(p)
no:	rest a
	return

.scalar rfnprm			; filename prompt routine
.scalar rfnblk			; filename default

;;;CALL READFN:  Read filename
;;; A (arg): prompt routine
;;; B (arg, val): filename block
readfn:	save c
	save d
	save e
	save b
	movem a,rfnprm
	movem b,rfnblk
	move a,[440700,,linbuf]
	movei b,5*llinbuf
	movei c,[
	  call @rfnprm
	  format " (Default ~F): ",rfnblk
	  return]
	call (c)
	call readln
	rest b
	move d,[440700,,linbuf]
	call rfn"rfn
	rest e
	rest d
	rest c
	return

;;;CALL NUMP:  Skip if token is all digits.
;;; A (arg, val): sixbit token
nump:	move tt,a
nump1:	setzi t,
	lshc t,6
	cail t,'0
	 caile t,'9
	  return
	jumpn tt,nump1
	aos (p)
	return

; CALL DEVNUM:  Create numerical device name
; A (arg):  number
; B (arg):  right justified device name with 0's (like PK0000).
; B (arg):  right justified device name (like PK0017).
devnum:	move t,b
	idivi a,8
	add b,t
	jumpe a,cpopj
	rot b,-6
	call devnum
	rot b,6
	return

;;;CALL NUMBER:  Return number (decimal) typed all on a single line.
;;; A (arg): prompt routine
;;; A (val): number
;;; +0: user typed something suprising
;;; +1: user typed a number
number:	save b
	save c
	movem a,prompt
numbr0:	setzb c,linct
numbr1:	jsp b,class
	 jrst numbr1
	 jrst numbrx
	 jrst numbr2
	 jrst numbrx
	 jrst numbr0

numbr2:	imuli c,10.
	addi c,-"0(a)	
	jsp b,class
	 jrst numbr9
	 jrst numbrx
	 jrst numbr2
	 jrst numbrx
	 aos -2(p)
	jrst numbrx

numbr9:	jsp b,class
	 jrst numbr9
	 jrst numbrx
	 jrst numbrx
	 jrst numbrx
	 aos -2(p)
numbrx:	move a,c
	rest c
	rest b
	return

;;;CALL TOKEN:  Return sixbit token typed all on a single line.
;;; A (arg): prompt routine
;;; A (val): word of SIXBIT
;;; +0: user typed something suprising
;;; +1: user typed a token
token:	save b
	save c
	save d
	movem a,prompt
token0:	setzm linct
	move c,[440600,,d]
	setzi d,
wscan:	jsp b,class
	 jrst wscan
	 jrst gotcha
	 jrst gotcha
	 jrst tokenx
	 jrst token0

gotcha:	subi a,40
	tlne c,770000
	 idpb a,c
	jsp b,class
	 jrst xscan
	 jrst gotcha
	 jrst gotcha
	 jrst tokenx
	 aos -3(p)
	jrst tokenx

xscan:	jsp b,class
	 jrst xscan
	 jrst tokenx
	 jrst tokenx
	 jrst tokenx
	 aos -3(p)
tokenx:	move a,d
	rest d
	rest c
	rest b
	return

;;;JSP B,CLASS:  Return and classify next character:
;;; A (val): character
;;; +0: whitespace
;;; +1: letter
;;; +2: digit
;;; +3: other
;;; +4: terminator
class:	call input
	caie a,40
	 cain a,^I
	  jrst 0(b)
	cain a,^M
	 jrst 4(b)
	cail a,"A
	 caile a,"Z
	  skipa
	   jrst 1(b)
	cail a,"0
	 caile a,"9
	  skipa
	   jrst 2(b)
	cail a,"a
	 caile a,"z
	  jrst 3(b)
	subi a,"a-"A
	jrst 1(b)

llinbuf==:100.
.vector linbuf(llinbuf)
.scalar linbp
.scalar linct
.scalar prompt

input:	sosge linct
	 jrst input1
	ildb a,linbp
	return

input1:	save b
	save c
	move a,[440700,,linbuf]
	movei b,5*llinbuf
	move c,prompt
	call (c)
	call readln
	movem a,linbp
	movem b,linct
	rest c
	rest b
	jrst input

;;;READLN:  Read a line with rubout handling.
;;; A (arg, val): byte pointer for text
;;; B (arg): room for text
;;; B (val): length of text
;;; C (arg): reprompt routine
readln:	save d
	save e
	hrrzi c,(c)		; C: flags,,prompt
	move d,a		; D: bp
	move e,b		; E: room
readlp:	tyi t
	cain t,177
	 jrst rubout
	cain t,^U
	 jrst flush
	cain t,^G
	 jrst abort
	caie t,^L
	 cain t,^R
	  jrst replay
	cain t,^M
	 jrst readex
	sosg e
	 .lose
	idpb t,d
	jrst readlp

flush:	move e,b
replay:	tyo [^P]
	tyo ["A]
	call (c)
	move d,a
	move tt,b
	sub tt,e
	syscall siot,[movei echoch ? d ? tt]
	 .lose %lssys
	jrst readlp

rubout:	aos e
	camle e,b
	 jrst abort
	add d,[070000,,]
	skipge d
	 sub d,[430000,,1]
	tyo [^P]
	tyo ["X]
	jrst readlp

readex:	idpb t,d
	subi b,-1(e)
	rest e
	rest d
	return

siot:	setz
	sixbit /siot/
	movei ttyoch
	move t
	setz tt

variables

fsblk::
fsdev:	-1
fsfn1:	sixbit /.FEFS./
fsfn2:	-1
fsdir:	sixbit /./

cnstnts:
constants

fspage==:<.+1777>_-12
fsbase==:fspage_12

;;; Here are the file addresses of various interesting things in the file:

readme=:fsbase+0		; Start of first block is ASCII explanation.

dir=:fsbase+1000		; Directory is halfway through first block
ramptr=:dir+88ram
btptr=:dir+88bt
bt1ptr=:dir+88bt1
b2ptr=:dir+88b2
repeat nfifls, conc fi,\.rpcnt,ptr=:dir+88fi0+.rpcnt

ram=:fsbase+2000		; These blocks must be contiguous.
ramblk==:<ram-fsbase>_-12	; First such block
ramlen==:6			; Number of such blocks

bt=:ram+<ramlen_12>

bt1=:bt+1000

b2=:bt1+1000

repeat nfifls, conc fi,\.rpcnt,=:b2+1000+<1000*.rpcnt>

fsmax=:b2+1000+<1000*nfifls>

fslen==:<<fsmax+1777>_-12>-fspage	; Minimum number of blocks.

end go
