/PFOC0B -- PS/8 FOCAL LIBRARY ROUTINES



/ASSEMBLY INSTRUCTIONS:

/.R PAL8
/*PFOCLB,PFOCLB<PFOC0B,PFOC1B,PFLOTB,PFOCNB,DOLLAR
/.R ABSLDR
/*PFOCLB,INITAL=10200$
/.SAVE SYS PFOCLB
/.R PFOCLB

/(DOLLAR CONTAINS DOLLAR SIGNS TO TERMINATE THE ASSEMBLY)

/IDENTITIES TO HELP ELIMINATE INTERRUPTS
	ION=NOP
	IOF=NOP




	FIELD 0

	*10
AUTO1,	0		/AUTO-INDEX REGISTERS...ACTUALLY USE SOME
AUTO2,	0
AUTO3,	0
AUTO4,	0
AUTO5,	0
AUTO6,	0
AUTO7,	0
AUTO8,	0
XCNTR,	0		/GENERAL COUNTER--SUCH AS FOR MPD2,MPD3
USR,	7700		/POINTER TO MONITOR (200 IF IN CORE)
PEXIT,	JMS I [DISMIS	/NORMAL RETURN FOR PS/8 COMMANDS
	CDF CIF 10
	JMP I .+1
	GOSWITCH-3

NAMLOC,	ZBLOCK 3
EXTENSION,	0		/"FC" OR "FD"
LISTFLG,	0
NEWDEV,	ZBLOCK 2
TEM7,	0
ATEM,	0
XCHAR,	CHAR
SHNDLR,	7607
	/DEFINE LOWER FIELD INSTRUCTIONS . . .

	TGETC=JMS I .
	XGETC
	TPOPA=JMS I .
	MPOPA
	TPUSHA=JMS I .
	MPUSHA
	TPUSHF=JMS I .
	MPD2
	TPOPF=JMS I .
	MPD3
	TSORTJ=JMS I .
	MSORTJ

ECHFLG,	0
OPNFLG,	0
IPNFLG,	0
FLNGTH,	0
STBLK,	0
DEVNO,	0
LIBBLK,	0		/FOR DEVICE NAME
	0
	7400		/LOAD POINT
	0		/FOR DEVICE #
LIBHND,	0		/HANDLER ENTRY
	TESTRM=JMS I .
	MSORTC
	ERROR1=JMS I .
	ERROR
	*66
CHAR,	0		/FOR OBSCURE FAKING REASONS

INBLK,	0
	0
	5000
	0
INHND,	0

OUTBLK,	0
	0
	5200
	0
OUTHND,	0

	TPRINTC=JMS I .
	MPRINTC
	TGETLN=JMS I .
	MGETLN
	TSPNOR=JMS I .
	XTSPNOR
LIBFIL,	0
DEVHLD,	0

	PAGE
	/INITIAL TEXT FOR PS/8 FOCAL

	*200
PC0,	0
	0
	0
	0
	0
	5051
	BUFR
	LINE1
LINE0,	0
	0
	TEXT "C-PS/8 FOCAL, 1974"
	*.-1
	7715		/DUMMY CR
	LINE1=.
	PAGE
/PS/8 FOCAL FILE ROUTINES

	*3614

RESTORE,TSPNOR		/'OPEN RESTORE' COMMAND
	TAD CHAR	/SAVE COMMAND CHAR (3 WORD COMMAND!)
	TPUSHA
	TGETC
	TESTRM		/GO TO END OF COMMAND WORD
	SKP CLA
	JMP .-3
	CLA CLL CMA	/INITIALIZE ECHO SWITCH
	DCA ECHFLG
	JMS I [NAME	/JUST TO SET ECHO MODE
	TPOPA
	TAD [-"I	/OPEN RESTORE INPUT?
	SNA
	JMP I [IRST	/YES
	TAD ["I-"O	/NO, MUST BE OUTPUT
	SZA CLA
	ERROR1		/NEITHER ONE!
	JMP I [ORST

OCLOSE,	0		/CLOSE THE OPEN OUTPUT FILE
	TAD OPNFLG
	SNA CLA		/DON'T BOTHER IF IT ISN'T OPEN
	JMP I OCLOSE
	TAD [232	/WRITE '^Z'
	JMS NOCHAR
	TAD OPTR1	/PAD BUFFER WITH ZEROS
	TAD (-4400	/(AND WRITE IT OUT)
	SZA CLA
	JMP .-4
	TAD DEVHLD	/SAVED DEVICE #
	CIF 10
	JMS I USR
	4
	ONMTMP		/POINTER TO SAVED NAME
BLKCNT,	0		/FILE LENGTH (BLOCKS)
	ERROR1		/HUH?
	DCA OPNFLG	/CLEAR 'FILE OPEN' FLAG
	CDF 10
	TAD [XOUTL	/RESTORE TELETYPE OUTPUT ROUTINE
	DCA I [OUTDEV
	CDF
	JMP I OCLOSE	/DO WHATEVER ELSE NEEDS TO BE DONE

NOCHAR,	0		/PS/8 3/2 BUFFERED CHARACTER OUTPUT
	JMS I [FLDSET	/CALLED FROM EITHER FIELD
	DCA CCIF	/SAVE CALLING FIELD
	CDF
	TAD ATEM	/CHARACTER TO BE OUTPUT
	AND (377	/MASK OUT GARBAGE
	ISZ O3		/WHICH CHAR OF THREE?
	JMP O2		/STRAIGHT PACKING
	JMS RT		/HALF WORD PACKING - PACK FIRST HALF
	TAD ATEM	/GET SAVED ARG
	JMS RT		/PACK SECOND HALF
	CLA CLL CMA RTL	/RESET 3-WAY SWITCH
	DCA O3
	ISZ OCHCT	/BUFFER CAN ONLY BE FILLED WITH 3RD CHAR OF 3
	JMP CCIF	/NOT FULL YET, RETURN TO CALLING ROUTINE
	JMS I [PUTDEV	/TELL THE MONITOR THIS HANDLER'S IN CORE
		OUTHND-1	/POINTER TO DEVICE # AND ENTRY
	CLA CLL
	TAD OLNGTH	/-MAXIMUM ALLOWABLE LENGTH
	TAD BLKCNT	/LENGTH SO FAR
	SZL CLA		/HAS HE GONE TOO FAR?
	JMP OOVER	/YES, KILL HIM
	JMS I OUTHND	/WRITE ONE BLOCK BUFFER
	4200
	4400
OBLK,	0
	JMP I [DERR	/DEVICE ERROR
	ISZ OBLK	/BUMP OUTPUT BLOCK
	ISZ BLKCNT	/AND COUNT OF BLOCKS SO FAR
	JMS OSETUP	/RESET POINTERS FOR NEXT BUFFER
	JMP CCIF
O2,	DCA I OPTR1	/NORMAL PACKING IS EASY!
	ISZ OPTR1	/BUMP POINTER
CCIF,	HLT		/FILLED WITH CIF CDF
	JMP I NOCHAR

	O3=.		/WHY NOT?
RT,	0		/HALF-WORD PACK ROUTINE
	CLL RTL
	RTL
	DCA ATEM	/SAVE FOR SECOND HALF
	TAD ATEM
	AND [7400
	TAD I OPTR2	/ADD IN CHARACTER IN RIGHT HALF
	DCA I OPTR2	/PACK IT
	ISZ OPTR2	/BUMP POINTER AGAIN
	JMP I RT

OOVER,	DCA OPNFLG	/HE BLEW IT - KILL THE FILE!!
	TAD DEVHLD
	CIF 10
	JMS I USR
	4
	ONMTMP
	0		/LENGTH OF ZERO TO DELETE
O7600,	7600		/IGNORE ERRORS
	ERROR1		/BECAUSE WE ALREADY KNOW ABOUT THEM

OSETUP,	0		/RESET ALL THE POINTERS (WHAT FUN!)
	TAD OBLK-1
	DCA OPTR1
	TAD OBLK-1
	DCA OPTR2
	CLA CLL CMA RTL
	DCA O3
	TAD O7600
	DCA OCHCT
	JMP I OSETUP

OPTR1,	0
OPTR2,	0
OLNGTH,	0
OCHCT,	0

	PAGE
	*5400

OOPEN,	JMS I [IOWAIT	/WAIT FOR TELETYPE TO FINISH (DECTAPES ARE SLOW!)
	JMS I [OPEN	/CALL USR, HANDLER; ENTER OUTPUT FILE
YINT,		OUTBLK-1	/OUTPUT HANDLER BLOCK
		3	/MONITOR 'ENTER' CODE
YBLK,	JMP TTYOUT	/'OPEN OUTPUT TTY:'
	JMP OCLCHK	/ERROR ON ENTER - SEE IF FILE ALREADY OPEN
	JMS I [DISMISS	/KICK USR OUT
	TPUSHF		/SAVE NAME AND OTHER CRAP
		NAMLOC
	TPOPF
		ONMTMP
	TAD STBLK	/STARTING BLOCK
	DCA I (OBLK
	TAD FLNGTH	/-MAXIMUM ALLOWABLE LENGTH
	DCA I (OLNGTH
	JMS I (OSETUP	/SET UP PACKING POINTERS
	CLA CLL CMA	/THERE'S A FILE OPEN!
	DCA OPNFLG
	TAD DEVNO	/SAVE FOR CLOSE
	DCA DEVHLD
	DCA I (BLKCNT	/DITTO
ORST,	TAD OPNFLG	/ENTRY FOR 'OPEN RESTORE OUTPUT'
	SNA CLA		/IF 'OPEN OUTPUT', FLAG IS ALREADY SET
	ERROR1		/NO OUTPUT FILE TO RESTORE
	CDF 10
	ISZ ECHFLG	/SKIP IF NO ECHO
	TAD IBLK+2
	DCA I (OUTECH	/SET OUTPUT ROUTINE
	TAD (OCHAR	/POINTER TO FILE OUTPUT ROUTINE
	CIF CDF 10
	DCA I [OUTDEV
	JMP I [PROC	/FINISH THE LINE
TTYOUT,	TAD [XOUTL	/SWITCH OUTPUT TO TELETYPE (INTERRUPT)
	JMP .-5

FILEST,	TAD I XCHAR	/HERE'S WHERE FILES START!!
	DCA CHAR	/GET NEXT CHAR
	CDF
	TAD (604	/SET '.FD' ASSUMED EXTENSION
	DCA EXTENSION
	TSPNOR		/SKIP SPACES
	TAD CHAR	/SAVE COMMAND CHAR
	TPUSHA
	TGETC
	TESTRM		/GO TO END OF COMMAND WORD
	SKP CLA
	JMP .-3
	TPOPA
	TSORTJ		/GO DO COMMAND
		FILIST-1
		FILGO-FILIST
	ERROR1		/OOPS - BAD 'O' COMMAND

ICHAR,	0		/GET A CHARACTER FROM A FILE
	CLA CLL		/MAKE SURE
	ISZ INCHT	/DO WE NEED ANOTHER BUFFER?
	JMP I RDPTR	/NO, UNPACK THE CHARACTER
	JMS I INHND	/YES, GO GET IT
	0200
	4000
IBLK,	0
	SMA CLA		/ONLY BOTHER WITH FATAL ERRORS
	SKP CLA
	JMP I [DERR	/WE'VE GOT ONE
	ISZ IBLK	/BUMP TO NEXT BLOCK
	TAD IBLK-1	/AND RESTORE POINTERS
	DCA IPNTR
	TAD [7200
	DCA INCHT
ICHAR1,	TAD I IPNTR	/STRAIGHTFORWARD UNPACK ROUTINE
	JMS RDPTR	/DO COMMON CRAP
ICHAR2,	TAD I IPNTR	/SAVE LEFT HALF FOR LATER
	AND [7400
	DCA ITEMP
	ISZ IPNTR	/INCREMENT TO NEXT WORD
	TAD I IPNTR	/ANOTHER EASY ONE
	JMS RDPTR
ICHAR3,	TAD I IPNTR	/THIS IS THE TRICKY ONE!
	ISZ IPNTR	/GET LOW-ORDER HALF
	AND [7400
	CLL RTR		/SHIFT RIGHT
	RTR
	TAD ITEMP	/GET HIGH-ORDER HALF (REMEMBER?)
	RTR		/SHIFT SOME MORE
	RTR
	JMS RDPTR	/GOT IT!
	JMP ICHAR1	/1-2-3-1-2-3-1-2-3 ...

RDPTR,	0		/IF YOU DIDN'T KNOW, THIS IS A COROUTINE!
	AND [177	/ISN'T THAT AMAZING?
	SNA		/IGNORE NULLS AND PARITY
	JMP ICHAR+1
	TAD (-32	/END OF FILE? (^Z)
	SZA
	JMP .+5		/NO
	DCA IPNFLG	/YES, CLEAR OPEN FILE FLAG
	CDF 10		/AND SET UP CLEVER KLUDGE
	TAD (EOF	/TO CHECK FOR A STUPID
	DCA I [INDEV	/'ATTEMPT-TO-READ-PAST-EOF'!
	TAD [232	/PASS ^Z TO PROGRAM (MIGHT COME IN HANDY)
	CIF CDF 10
	JMP I ICHAR

ITEMP,	0
IPNTR,	0
INCHT,	0
ONMTMP,	ZBLOCK 4

	PAGE
IOPEN,	JMS I [IOWAIT	/WAIT FOR TELETYPE (DECTAPES ARE STILL SLOW!)
	JMS I [OPEN	/CALL THAT AMAZING GENERAL-PURPOSE SUBROUTINE
		INBLK-1
		2	/MONITOR 'LOOKUP'
	JMP TTYIN	/'OPEN INPUT TTY:'
	ERROR1		/WHOOPS - FILE NOT FOUND
	JMS I [DISMISS	/BOOT THE USR OUT
	TAD STBLK	/SET POINTERS AND OTHER CRAP
	DCA I (IBLK
	CLA CLL CMA
	DCA IPNFLG
	CLA CLL CMA
	DCA I (INCHT
IRST,	TAD IPNFLG	/'OPEN RESTORE INPUT' COMES HERE
	SNA CLA		/FLAG IS SET ALREADY IF 'OPEN INPUT'
	ERROR1		/NO INPUT FILE TO RESTORE
	TAD (ICHARF	/SET I/O POINTERS
	CIF CDF 10
	DCA I [INDEV
	ISZ ECHFLG	/AND ECHO MODE
	TAD [PRINTC
	DCA I [PPRNT
	JMP I [PROC
TTYIN,	TAD [XI33	/'OPEN INPUT TTY:'
	JMP TTYIN-7

MPUSHA,	0		/PUSH THE AC ON THE STACK
	JMS FLDSET	/CALLED FROM EITHER FIELD
	DCA ACDF
	CDF 10		/DO SOME CRAZY, MIXED-UP POINTER SCRAMBLING
	TAD I (PDLXR
	DCA TEM7
	CMA
	TAD TEM7
	DCA I (PDLXR
	TAD TEM7
	CIA CLL
	TAD I [BUFR
	SZL CLA
PDERR,	ERROR1		/PUSHDOWN OVERFLOW
	TAD I (PDLXR
	CDF
	DCA AUTO2
	TAD ATEM
	DCA I TEM7
ACDF,	CIF CDF
	JMP I MPUSHA

MPD2,	0		/PUSH 4 WORDS ON THE STACK
	TAD I MPD2	/GET POINTER TO FIRST WORD
	TAD [3		/PUSH IN REVERSE ORDER
	DCA MPD3
	ISZ MPD2
	JMS FLDSET
	DCA FCDF
	CDF
	TAD [-4
	DCA XCNTR
FCDF,	HLT		/CHANGE FIELD TO CALLING FIELD
	TAD I MPD3	/GET THE NEXT WORD
	CIF CDF
	JMS MPUSHA	/PUSH IT
	CLA CLL CMA	/BACK UP POINTER
	TAD MPD3
	DCA MPD3
	ISZ XCNTR
	JMP FCDF	/GET THE NEXT ONE
	TAD FCDF
	DCA .+1
	0		/RESTORE CALLING FIELD
	JMP I MPD2

MPD3,	0		/POP 4 WORDS
	CLA CLL CMA	/GET POINTER-1
	TAD I MPD3
	DCA AUTO3
	ISZ MPD3
	TAD (CDF
	RDF
	DCA FCIF
	TAD [-4		/FOUR WORDS
	DCA XCNTR
	CDF
	JMS MPOPA	/GET ONE
FCIF,	CDF
	DCA I AUTO3	/PUT IT AWAY
	ISZ XCNTR	/ALL DONE?
	JMP FCIF-2	/NO, GET ANOTHER
	CLL CLA CML RTL	/YES, CHANGE CDF TO CIF CDF
	TAD FCIF
	DCA .+1
	0		/CHANGE FIELD AND EXIT
	JMP I MPD3

MPOPA,	0		/POP A WORD
	JMS FLDSET	/(THIS ONE'S EASY)
	DCA ACIF
	CDF 10
	ISZ I (PDLXR
	CDF
	TAD I AUTO2
ACIF,	CIF CDF
	JMP I MPOPA

FLDSET,	0
	DCA ATEM
	TAD FCDF+2
	RDF
	JMP I FLDSET

XRESTOR,TAD LISTFLG	/PART OF ERROR ROUTINE TO
	SZA CLA		/RESET I/O TO CONSOLE TERMINAL AND
	JMS SWAPIN	/RESTORE CORE SWAPPED BY DIRECTORY
	CIF CDF 10	/LISTING
	JMP RECOVY

MSORTC,	0		/CHECK FOR TERMINATOR
	CIF CDF 10
	JMS I [TERMER
	ISZ MSORTC
	JMP I MSORTC

	PAGE
/LIBRARY COMMAND PROCESSOR

	/****** STORAGE ALLOCATION MAP ******
	/*****				*****
	/*	3600	FILES (OUTPUT AND RESTORE)
	/*	4000	INPUT BUFFER (PAGE 1)
	/*	4200	INPUT BUFFER (PAGE 2)
	/*	4400	OUTPUT BUFFER (PAGE 1)
	/*	4600	OUTPUT BUFFER (PAGE 2)
	/*	5000	INPUT HANDLER
	/*	5200	OUTPUT HANDLER
	/*	5400	FILES (INPUT AND OPEN)
	/*
	/*	5600	PUSHDOWN LIST CONTROLS
	/*	6000	NAME, GTMON, DISMISS, IOWAIT
	/*	6200	HANDAD, COMPARE
	/*	6400	LOWLIB, SAVER, RETURN
	/*	6600	CHAINER, FETCHER, GOSUB
	/*	7000	LIBRARIAN
	/*	7200	MISCELLANEOUS
	/*	7400	LIBRARY HANDLER
	/*****				*****
	/************************************




NAME,	0		/READ A DEV:FILENAME.EX STRING INTO 'NAMLOC' & 'NEWDEV'
	JMS DISMIS	/'GETC' WON'T WITH THE USR IN CORE
	TAD (5723	/CODE FOR 'DSK:'
	DCA NEWDEV	/(DEFAULT DEVICE)
	DCA NEWDEV+1
	JMS GNAME	/GET FIRST PART (MIGHT BE DEVICE)
	TAD ["A-":	/WAS IT A DEVICE?
	SZA CLA
	JMP I NAME	/NO, ALL SET UP
	TGETC		/YES, MOVE PAST ':'
	TAD NAMLOC	/MOVE TO DEVICE AREA
	DCA NEWDEV
	TAD NAMLOC+1
	JMP NAME+4	/GET FILENAME

GNAME,	0		/READ A NAME INTO 'NAMLOC'
	DCA NAMLOC	/CLEAR NAME AREA
	DCA NAMLOC+1	/(DON'T CLEAR ASSUMED EXTENSION)
	DCA NAMLOC+2
	TAD [NAMLOC	/INITIALIZE POINTERS
	DCA NMBASE
	CLA CMA
	DCA PERDSW
	DCA NAMECT
	TSPNOR
	SKP
NAMEC,	TGETC		/MAIN LOOP
	TAD CHAR	/LOWER FIELD COPY, OF COURSE
	TAD [-".	/EXTENSION?
	SNA
	JMP PERD	/YES, CLEAR DEFAULT EXTENSION
	TAD [".-",	/COMMA?
	SNA CLA
	JMP ECHCHK	/YES, CHECK FOR ECHO
ECHGO,	JMS DECODE	/MUST BE A-Z, 0-9
	JMP I GNAME	/IT WASN'T, MUST BE END OF NAME
	SZL		/RESTORE CHARACTER
	TAD [57
	IAC
	DCA DECODE	/TEMPORARY STORAGE
	TAD NAMECT	/NO MORE THAN 6 CHARACTERS/NAME
	TAD [-6
	SMA CLA
	JMP NAMEC
	TAD NAMECT	/BUILD POINTER TO CHARACTER POSITION
	CLL RAR
	TAD NMBASE
	DCA TT
	TAD DECODE	/LEFT OR RIGHT HALF?
	SZL
	JMP .+4
	CLL RTL		/LEFT, SHIFT OVER
	RTL
	RTL
	TAD I TT	/ADD IN OTHER HALF
	DCA I TT
	ISZ NAMECT	/BUMP COUNT
	JMP NAMEC	/CONTINUE LOOP

PERD,	TAD NAMLOC	/FOUND A PERIOD IN STRING
	SZA CLA
	ISZ PERDSW
	ERROR1		/DOUBLE PERIODS OR NO FILE NAME
	DCA EXTENSION	/CLEAR EXTENSION
	TGETC		/MOVE PAST PERIOD
	ISZ NMBASE	/FAKE OUT POINTERS
	TAD [4
	JMP NAMEC-3

ECHCHK,	TGETC		/MOVE PAST COMMA
	TSPNOR
	TAD CHAR	/MUST BE FOLLOWED BY 'ECHO'
	TAD [-"E
	SZA CLA
	JMP I GNAME
	DCA ECHFLG	/SET ECHO FLAG
	TGETC		/MOVE TO END OF WORD
	JMS DECODE
	JMP I GNAME
	CLA CLL
	JMP .-4

DECODE,	0		/CHECK FOR A-Z, 0-9
	TAD CHAR
	TAD [-"9-1
	CLL
	TAD ["9+1-"0
	SZL
	JMP DCDYES
	TAD ["0-"Z-1
	CLL CML
	TAD ["Z-"A+1
	SNL
DCDYES,	ISZ DECODE	/IT WAS!
	JMP I DECODE

NMBASE,	0
PERDSW,	0
NAMECT,	0
TT,	0

IOWAIT,	0		/WAIT FOR TELETYPE TO FINISH
	TSF
	JMP .-1
	JMP I IOWAIT

GTMON,	0		/LOCK THE USR IN CORE
	CIF 10		/(NOP IF ALREADY IN CORE)
	JMS I USR
	10
	TAD [200	/SET POINTER FOR LATER CALLS
	DCA USR
	JMP I GTMON

DISMIS,	0		/IF THE USR IS IN, KICK IT OUT
	CLA CLL
	TAD USR		/CHECK POINTER TO FIND OUT
	SPA CLA
	JMP I DISMIS
	CIF 10
	JMS I USR
	11
	TAD ECHGO+10	/RESET POINTER
	DCA USR
	JMP I DISMIS

	PAGE
HANDAD,	0		/LOADS HANDLER INTO PROPER SLOT
	TAD I HANDAD	/WHICH SLOT?
	ISZ HANDAD
	DCA SLOT
	JMS COMPARE	/IF THE HANDLER HAS THE SAME NAME,
		-2	/DON'T LOAD IT AGAIN
SLOT,		0
		NEWDEV-1
	JMP NOTEQ	/DIFFERENT NAMES, LOAD NEW HANDLER
	ISZ AUTO5
	TAD I AUTO5	/(SET BY 'COMPARE')
	DCA DEVNO	/MOVE DEVICE # (FOR SAVE AND CLOSE)
	TAD AUTO5	/POINTS TO DEVICE #
	DCA .+2
	JMS I [PUTDEV	/SO USR KNOWS IT'S IN CORE
		0
	JMP I HANDAD

NOTEQ,	ISZ SLOT	/BUMP POINTER TO SAVE NAME
	TAD NEWDEV	/MOVE NEW DEVICE NAME TO TABLE
	DCA I SLOT
	ISZ SLOT
	TAD NEWDEV+1
	DCA I SLOT
	ISZ SLOT
	JMS I [GTMON	/WE MUST CALL THE USR, MIGHT AS WELL LOCK IT IN
RETRY,	TAD NEWDEV	/MOVE DEVICE NAME FOR MONITOR CALL
	DCA DEVC
	TAD NEWDEV+1
	DCA DEVC+1
	TAD I SLOT	/MOVE LOAD POINT
	DCA DLOAD
	CIF 10
	JMS I USR	/CALL MONITOR (ALREADY IN CORE)
	1
DEVC,	0
	0
DLOAD,	0
	ERROR1		/DEVICE NOT AVAILABLE OR TWO PAGE HANDLER
	CLL
	TAD DLOAD	/ENTRY POINT FOR HANDLER
	TAD [200	/IF THIS HANDLER IS IN PAGE 7600,
	SZL CLA		/DON'T BOTHER TO CHECK FOR LEGALITY
	JMP HANDOK	/SYSTEM HANDLER
	TAD DLOAD	/IF THE HANDLER WAS NOT LOADED
	AND [7600	/INTO THE PROPER PAGE, RELOAD IT!
	CLL CIA
	TAD I SLOT	/PROPER LOADING ADDRESS
	SNA CLA
	JMP HANDOK	/EVERYTHING'S ALL RIGHT
	DCA DLOAD	/CLEAR ENTRY POINT
	JMS I [PUTDEV	/TELL USR THE HANDLER IS NOT
		DEVC+1	/IN CORE ANYMORE
	JMP RETRY	/LOAD IT THIS TIME

HANDOK,	ISZ SLOT	/BUMP POINTER TO DEVICE #
	TAD DEVC+1	/SAVE IT
	DCA I SLOT
	ISZ SLOT	/MOVE TO ENTRY POINT
	TAD DLOAD	/SAVE ENTRY
	DCA I SLOT
	TAD DEVC+1	/GET DEVICE #
	DCA DEVNO	/SAVE IT AND EXIT
	JMP I HANDAD

COMPARE,0		/COMPARE TWO BLOCKS OF INDEFINITE LENGTH
	TAD I COMPARE	/CALLING SEQUENCE:
	ISZ COMPARE	/JMS COMPARE
	DCA XCNTR	/	-# OF WORDS TO CHECK
	TAD I COMPARE	/	FIRST-1
	ISZ COMPARE	/	SECOND-1
	DCA AUTO5	/RETURN IF MATCH
	TAD I COMPARE	/RETURN IF NO MATCH
	ISZ COMPARE
	DCA AUTO6
AGAIN,	TAD I AUTO5	/COMPARE TWO WORDS
	CIA
	TAD I AUTO6
	SZA CLA
	JMP I COMPARE	/NO MATCH
	ISZ XCNTR	/FINISHED?
	JMP AGAIN	/NO, CHECK NEXT TWO
	ISZ COMPARE	/YES, BUMP RETURN POINTER
	JMP I COMPARE

MPRINTC,0		/CROSS-FIELD 'PRINTC'
	CIF CDF 10
	JMS I (CPRNT
	JMP I MPRINTC

TABCNT,	0		/TAB COUNTER (ONLY PRINTING CHARACTERS)
	TAD (-15	/7-BIT CR MEANS RETURN ONLY
	SNA
	JMP CRONLY
	TAD [-200	/CHECK FOR CR
	SNA
	JMP NEWLIN	/TYPE CR,LF
	ISZ TABCNT
	TAD (215-240
	SMA
	ISZ I TABCPT	/IT PRINTS, INCREMENT COUNT
	NOP		/IT JUST MIGHT SKIP
	TAD [240
	CIF 10
	JMP I TABCNT

CRONLY,	TAD [215
	CIF 10
	JMS I [PRINTX
	DCA I TABCPT
	TAD [200	/NULL FOR DELAY
	JMP TABCNT+1

NEWLIN,	DCA I TABCPT
	JMP CRONLY-2

TABCPT,	TABC

COMLIST,"S		/SAVE
	"C		/CALL
	"R		/RUN
	"L		/LIST
	"D		/DELETE
	"G		/GOSUB
	" 		/FAKE A 'LIBRARY RETURN' WITH A SPACE
	"E		/EXIT

FILGO,	IOPEN
	OOPEN
	OCLOSR
	RESTOR

	PAGE
	/ACTUAL LIBRARY PROCESSOR
	/STARTING WITH COMMAND DECODE:

LOWLIB,	CDF 10		/CLEAR SWITCH FOR NORMAL RETURN
	DCA I [GOSWITCH	/I.E. TO 'PROC' FOR REST OF LINE
	TAD I XCHAR	/MOVE CURRENT CHARACTER DOWN
	CDF
	DCA CHAR
	TAD CHAR	/SAVE FOR COMMAND SORT
	TPUSHA
	TAD [603	/'.FC' ASSUMED EXTENSION
	DCA EXTENSION
	SKP CLA		/MIGHT BE A TERMINATOR ALREADY
	TGETC		/MOVE TO END OF COMMAND WORD
	TESTRM
	SKP
	JMP .-3
	TPOPA		/RESTORE COMMAND CHAR
	TSORTJ		/AND BRANCH TO APPROIATE ROUTINE
		COMLIST-1
		PCOMGO-COMLIST
	ERROR1		/SORRY, CHARLIE!

PCOMGO,	SAVER
	FETCHER
	CHAINER
	LIBRARIAN
	PDELET
	GOSUB
	PRETRN
C7600,	7600

SAVER,	JMS I [NAME	/GET NAME FOR SAVE
	JMS PSAVE	/DO IT
	JMP PEXIT	/EASY, WASN'T IT?

PSAVE,	0		/CALLED BY 'SAVE' AND 'GOSUB'
	JMS OCHK	/CLOSE OUTPUT FILE TO AVOID TROUBLE
	TAD [NAMLOC	/POINTER TO NAME
	DCA SAVEPT
	CDF 10
	TAD I [BUFR	/GET PROGRAM LENGTH
	CDF
	DCA I [207	/SAVE IT WITH THE PROGRAM
	JMS I [GTMON	/CALL THE MONITOR
	JMS I [HANDAD	/AND THE HANDLER
		LIBBLK-1
	TAD I [207	/SAVED LENGTH, REMEMBER?
	AND C7600	/MASK OFF
	CLL RAR		/CONVERT TO PAGES
	DCA BLOCK	/FOR HANDLER
	TAD BLOCK	/ROUND UP TO BLOCKS
	TAD [100
	AND C7600
	CLL RTR
	RAR
	DCA RECORD	/FOR MONITOR 'ENTER'
	TAD RECORD	/GET DESIRED LENGTH
	TAD DEVNO	/(SET BY 'HANDAD')
	CIF 10
	JMS I USR	/ENTER OUTPUT FILE
	3
SAVEPT,	NAMLOC
	0
	ERROR1		/NO ROOM ON DEVICE
	TAD RECORD	/SHIFT FOR CLOSING LENGTH
	CLL RTR
	RTR
	DCA SAVBLK
	TAD DEVNO	/CLOSE THE FILE BEFORE WE WRITE IT!
	CIF 10		/(SURE, IT'S CHEATING, BUT
	JMS I USR	/IT SAVES TIME!)
	4
	NAMLOC
SAVBLK,	0
	ERROR1		/IMPOSSIBLE ERROR!
	TAD SAVBLK	/SAVE THIS CRAP TO REMEMBER
	CIA		/WHERE THIS PROGRAM IS
	DCA LIBLEN	/IN CASE WE WANT TO GOSUB
	TAD SAVEPT
	DCA LIBFIL
	TAD NEWDEV
	DCA LIBDEV
	TAD NEWDEV+1
	DCA LIBDEV+1
	TAD SAVEPT	/MOVE STARTING BLOCK FOR WRITE
	DCA POINT4
	CLL CML RAR	/COMPUTE FUNCTION WORD
	IAC		/SET TO SEARCH FORWARD
	TAD BLOCK	/HOW MUCH TO WRITE
	DCA BLLL
	JMS I LIBHND
BLLL,	0		/WRITE (BLOCK) BLOCKS FROM FIELD 0
	200		/FROM 200 UP
POINT4,	0
	JMP I [DERR	/GO COMPLAIN ABOUT DEVICE
	JMP I PSAVE

LIBLEN,	0
LIBDEV,	ZBLOCK 2
RECORD,	0
BLOCK,	0

PRETRN,	TPOPA		/GET BACK ALL THE JUNK WE SAVED
	CDF 10		/FOR THE LAST GOSUB
	DCA I XCHAR	/IN-LINE CHARACTER
	CDF
	TPOPF		/DEVICE NAME
		NEWDEV
	TPOPA		/FILE LENGTH
	DCA FLNGTH
	TPOPA		/STARTING BLOCK
	DCA STBLK
	JMS I [HANDAD	/GET THE HANDLER BACK
		LIBBLK-1
	JMP LOADGO	/LOAD THE PROGRAM

OCLOSR,	JMS I [OCLOSE	/CLOSE OUTPUT FILE
	CIF CDF 10
	JMP I [PROC	/ANOTHER EASY ONE!

PUTDEV,	0		/TELL THE MONITOR A HANDLER IS IN OR OUT
	TAD I PUTDEV	/GET POINTER TO DEV # AND ENTRY
	DCA RECORD
	TAD I RECORD	/DEVICE #
	ISZ RECORD	/BUMP POINTER TO ENTRY
	TAD (7646	/MONITOR TABLE
	DCA BLOCK	/POINTER TO 'HANDLER-IN-CORE' FLAG
	TAD I RECORD	/FLAG IS HANDLER ENTRY
	CDF 10		/TABLE IS IN FIELD 1
	DCA I BLOCK
	CDF
	ISZ PUTDEV
	JMP I PUTDEV

	PAGE
	/LOOKUP AND LOAD ROUTINES

CHAINER,IAC		/THESE ALL DO THE SAME THING
GOSUB1,	IAC		/AND THEN GO TO DIFFERENT PLACES
FETCHER,IAC
	CDF 10
	DCA I [GOSWITCH
	CDF
LOAD,	JMS I [OPEN	/CALL THE HANDLER AND LOOKUP THE FILE
		LIBBLK-1
		2
	JMP .+5		/TTY: NOT A DIRECTORY DEVICE
	ERROR1
	JMS I [DISMISS
	JMS I (GETDEV	/GET DEVICE TYPE
	SMA CLA
	ERROR1		/NOT A DIRECTORY DEVICE
	TGETLN		/SOME COMMANDS HAVE LINE NUMBERS
LOADGO,	JMS I [DISMISS	/ONLY USED BY 'RETURN'
	TAD STBLK	/BLOCK TO READ FROM
	DCA POINT6
	TAD AUTO2	/GET PUSHDOWN POINTER
	TAD [-200	/DIDDLE IT
	AND [7600
	CLL RAL
	RTL
	RTL
	TAD FLNGTH	/NOW COMPARE WITH LENGTH OF FILE
	SPA CLA
	JMP PDERR	/PROGRAM TOO LONG
	CDF 10
	CLA CLL CMA RAL	/(=-2)
	TAD I [GOSWITCH	/IS THIS A GOSUB?
	SZA CLA
	JMP .+7		/NO, SKIP THIS GARBAGE
	TAD I XCHAR	/YES, SAVE PROGRAM NAME, ETC.
	CDF
	TPUSHA
	TAD [215
	CDF 10
	DCA I XCHAR
	CDF
	TAD FLNGTH	/COMPUTE FUNCTION WORD
	CIA
	CLL RTL
	RTL
	RTL
	CLL CML RAL	/SET TO SEARCH FORWARD
	DCA LENF1
	JMS I LIBHND	/GET THE PROGRAM
LENF1,	3600
	0200
POINT6,	0
	JMP I [DERR
	TAD NEWDEV	/SAVE THIS STUFF SO WE
	DCA LIBDEV	/KNOW WHERE WE ARE
	TAD NEWDEV+1
	DCA LIBDEV+1
	TAD STBLK
	DCA LIBFIL
	TAD FLNGTH
	DCA LIBLEN
	TAD I [207	/MOVE PROGRAM LENGTH
	CDF 10
	DCA I [BUFR
	CDF
	JMP PEXIT	/GO TO APPROPRIATE ROUTINE

GOSUB,	TAD LIBFIL	/CHECK FOR CURRENT PROGRAM
	SZA
	JMP NOSAVE	/NO NEED TO SAVE CORE
	TPUSHF		/MOVE 'FOCAL.TM' TO NAME AREA
		FOCTXT
	TPOPF
		NAMLOC
	TAD (5723	/DEVICE 'DSK' FOR SAVE
	DCA NEWDEV
	DCA NEWDEV+1
	JMS PSAVE	/SAVE FILE (THIS WILL LEAVE USR IN CORE)
	TAD [603	/RESET EXTENSION TO 'FC'
	DCA EXTENSION
	JMS I [DISMISS	/KICK MONITOR OUT TO SAVE STARTING BLOCK
	TAD LIBFIL
NOSAVE,	TPUSHA		/'LIBFIL' STILL IN AC
	TAD LIBLEN
	TPUSHA
	TPUSHF
		LIBDEV
	JMP GOSUB1

XTSPNOR,0		/DUPLICATE UPPER FIELD ROUTINE
	TAD CHAR
	TAD [-240
	SZA CLA
	JMP I XTSPNOR
	TGETC
	JMP XTSPNOR+1

TTYTXT,	DEVICE TTY	/HANDY THING TO HAVE

MSORTJ,	0		/ANOTHER DUPLICATE
	CIA
	DCA ATEM
	TAD I MSORTJ
	ISZ MSORTJ
	DCA AUTO4
	TAD I AUTO4
	SPA
	JMP MSEX
	TAD ATEM
	SZA CLA
	JMP .-5
	TAD AUTO4
	TAD I MSORTJ
	DCA ATEM
	TAD I ATEM
	DCA ATEM
	JMP I ATEM

MSEX,	ISZ MSORTJ
	CLA CLL
	JMP I MSORTJ

FILIST,	"I		/INPUT
	"O		/OUTPUT
	"C		/CLOSE
	"R		/RESTORE

	PAGE
	/THIS SECTION DOES THE DIRTY WORK OF LISTING
	/ALL "FC"'S AND "FD"'S ON THE DEVICE REFERENCED
	/IT WAS FUN...

LIBRARIAN,	JMS I [NAME	/GET DEVICE TO LIST
	JMS I [HANDAD	/GET THE HANDLER
		LIBBLK-1
	JMS I [DISMISS	/KICK OUT USR (IN CASE HANDAD CALLED IT)
	JMS GETDEV	/FIND DEVICE TYPE
	SMA CLA
	ERROR1		/CAN'T LIST A NON-DIRECTORY DEVICE
	JMS I SHNDLR	/SWAP OUT CORE TO MAKE ROOM FOR DIRECTORY
	4200
	1000
	40		/SYSTEM SCRATCH AREA
	JMP I [DERR	/WHOOPS!
	CLA IAC		/SET FLAG TO SWAP BACK IN
	DCA LISTFLG
	CLL CLA IAC	/DIRECTORY BEGINS WITH BLOCK 1
BLOKLP,	DCA LBLOCK
	JMS I LIBHND
	0200
	1000
LBLOCK,	1
	JMP I [DERR
	TAD (1004	/FIRST 5 WORDS ARE INFORMATION
	DCA AUTO4
LOOP2,	TAD AUTO4	/SAVE FOR LATER
	DCA AUTO8
	TAD AUTO4
	DCA LIBX
	TAD I AUTO4	/LOOKING FOR .FC & .FD FILES
	SNA CLA
	JMP PATCH	/ZERO FILE
	ISZ AUTO4
	ISZ AUTO4
	TAD I AUTO4	/PICK UP EXTENSION
	DCA LBLOCK
	TAD I (1004	/WASTE WORDS (NEGATIVE)
	CIA		/THANKS FOR TELLING US, RITCHIE
	TAD AUTO4	/SKIP TO LENGTH
	DCA AUTO4
	TAD I AUTO4	/ZERO LENGTH MEANS TEMPORARY FILE
	SNA
	JMP LOOP3	/IGNORE SUCH THINGS
	CLL CIA
	DCA FLNGTH	/SAVE POSITIVE LENGTH
	TAD NAMLOC	/IF A NAME WAS GIVEN, SEE IF WE
	SNA CLA		/HAVE REACHED IT YET
	JMP TESTGO	/NO NAME
	JMS I [COMPARE	/COMPARE THIS NAME WITH ARG
		-4
LIBX,		0
		NAMLOC-1
	JMP LOOP3	/NON-MATCHING
	DCA NAMLOC	/WE FOUND IT, DON'T CHECK ANY MORE
TESTGO,	TAD LBLOCK	/COMPARE EXTENSION
	TAD (-604	/DO WE WANT THIS ONE?
	SZA
	IAC
	SZA CLA
	JMP LOOP3	/GUESS NOT
DIRLIST,CLA CLL CMA RTL	/PRINT 3 WORDS
	DCA COUNT
	TAD I AUTO8/SET BEFORE THIS
	JMS NPACK	/PRINT 2 CHARS
	ISZ COUNT
	JMP .-3
	TAD (".
	TPRINTC
	TAD I AUTO8	/PRINT EXTENSION
	JMS NPACK
	TAD (PTABLE	/SET UP FOR DECIMAL LENGTH PRINT
	DCA POINT
ZLOOP,	DCA ZERSW
	DCA COUNT
NLOOP,	TAD I POINT	/FINISHED ALL POWERS OF 10?
	SNA
	JMP NEND	/YES, ALL DONE
	TAD FLNGTH	/NO, SUBTRACT THIS POWER
	SPA		/UNDERFLOW?
	JMP PDIGIT	/YES, PRINT THIS DIGIT
	DCA FLNGTH	/NO, GO THROUGH THE LOOP AGAIN
	ISZ COUNT	/ADD ONE TO THIS DIGIT
	JMP NLOOP	/ANOTHER DIVIDE CYCLE

PDIGIT,	CLA CLL		/CRAP IN AC
	ISZ POINT	/NEXT POWER OF TEN
	TAD COUNT	/IF THIS DIGIT IS ZERO,
	ISZ ZERSW	/AND NO OTHER DIGITS HAVE BEEN NON-ZERO,
	SZA		/PRINT A SPACE INSTEAD
	JMP NPRNT
	TAD [240
	TPRINTC
	JMP ZLOOP
NPRNT,	TAD [260	/CHANGE TO ASCII
	TPRINTC
	CLA CLL CMA	/SET ZERO SWITCH
	JMP ZLOOP
NEND,	TAD [215	/DONE WITH THIS LINE (WHEW!)
	TPRINTC
	JMP LOOP3

PATCH,	ISZ AUTO4	/BUMP PAST EMPTY LENGTH
LOOP3,	ISZ I LBLOCK-1	/DONE WITH THIS BLOCK?
	JMP LOOP2	/NO, KEEP GOING
LEXIT,	JMS I [IOWAIT	/WAIT FOR I/O
	TAD I [1002	/LINK TO NEXT BLOCK
	SZA		/LAST BLOCK?
	JMP BLOKLP	/NO, GET THE NEXT
	JMS SWAPIN	/YES, RESTORE SWAPPED CORE AND EXIT
	JMP PEXIT

GETDEV,	0		/GET DEVICE TYPE FROM MONITOR TABLE
	TAD [7757	/DCB-1
	TAD DEVNO
	DCA COUNT
	CDF 10
	TAD I COUNT
	CDF
	JMP I GETDEV

	DECIMAL
PTABLE,	-1000
	-100
	-10
	-1
	0
	OCTAL

	POINT=NEWDEV
	ZERSW=NEWDEV+1
POINT7,	0
COUNT,	0

	PAGE
	/MISCELLANEOUS GENERAL-PURPOSE ROUTINES

	/THIS IS THE GENERAL OPEN SUBROUTINE
	/CALLNG SEQUENCE:
	/JMS I [OPEN
	/HANDLER BLOCK
	/MONITOR CALL CODE
	/RETURN IF TTY: IS DEVICE
	/ERROR RETURN
	/NORMAL RETURN
	/SETS STBLK, FLNGTH ON PAGE ZERO

OPEN,	0
	CLA CLL CMA	/INITIALIZE ECHO FLAG TO OFF
	DCA ECHFLG
	JMS I [NAME	/GET DEVICE AND FILENAME
	JMS I [COMPARE	/DEVICE 'TTY:' IS SPECIAL
		-2
		NEWDEV-1
		TTYTXT-1
	JMP OTHER	/DEVICE OTHER THAN TTY
	ISZ OPEN	/INCREMENT TO PROPER RETURN
	ISZ OPEN
	JMP I OPEN
OTHER,	TAD I OPEN	/GET HANDLER BLOCK TO USE
	DCA HND
	ISZ OPEN
	TAD [NAMLOC	/POINTER TO NAME
	DCA NAMPT
	JMS I [GTMON
	JMS I [HANDAD	/GET THE HANDLER
HND,		0	/SET TO HANDLER BLOCK
	TAD I OPEN	/GET MONITOR CALL CODE (2 OR 3)
	ISZ OPEN
	DCA CALL
	DCA LNGTH	/FOR MONITOR KLUDGE (IT FALLS THROUGH ON ERROR)
	TAD DEVNO	/DO THE CALL
	CIF 10
	JMS I USR
CALL,	0
NAMPT,	NAMLOC
LNGTH,	0
	JMP OTHER-2	/LET THE CALLING ROUTINE DECIDE ERROR PROCEDURE
	TAD LNGTH	/MOVE PARAMETERS TO PAGE ZERO
	DCA FLNGTH
	TAD NAMPT
	DCA STBLK
	JMP OTHER-3	/AND TAKE NORMAL RETURN

ERROR,	0		/LOWER FIELD ERROR ROUTINE
	JMS I [DISMIS	/MAKE SURE
	TAD ERROR	/FAKE OUT ERROR ROUTINE
	CIF CDF 10	/AND GO TO IT
	DCA I (ERR2
	JMP I (ERR2+1

PDELET,	JMS I [NAME	/DELETE IS AN EASY ONE (THANK GOD!)
	JMS I [GTMON
	JMS I [HANDAD
		LIBBLK-1
	JMS OCHK	/CLOSE ANY OPEN OUTPUT FILE
	CIF 10		/DELETE THE FILE
	TAD DEVNO
	JMS I USR
	4
	NAMLOC
	0
	ERROR1
	DCA LIBFIL	/IN CASE HE JUST DELETED THIS PROGRAM
	JMP PEXIT

OCHK,	0		/IF ANY FILE EXISTS, CLOSE IT
	TAD DEVHLD
	SZA CLA
	JMS OCLOSE
	JMP I OCHK

SWAPIN,	0		/RESTORE CORE AFTER DIRECTORY LIST
	DCA LISTFLG
	JMS I SHNDLR
	200
	1000
	40
DERR,	ERROR1		/DEVICE ERROR
	JMP I SWAPIN

NPACK,	0		/STANDARD 6-BIT UNPACK ROUTINE
	DCA OCHK
	TAD OCHK
	RTR
	RTR
	RTR
	JMS XFORM
	TAD OCHK
	JMS XFORM
	JMP I NPACK

XFORM,	0
	AND [77
	SZA		/PRINT SPACES FOR NULLS
	TAD (-40
	SPA
	TAD [100
	TAD [240
	TPRINTC
	JMP I XFORM

OCLCHK,	TAD OPNFLG	/MAKE 'OPEN OUTPUT' WITH AN ALREADY OPEN FILE
	SNA CLA		/THE SAME AS 'OUTPUT CLOSE;OPEN OUTPUT'
	ERROR1
	JMS OCLOSE
	TAD (YINT	/FAKE OUT 'OPEN'
	DCA OPEN
	JMP OTHER

MGETLN,	0		/CROSS-FIELD FAKE
	CIF CDF 10
	JMS I (PGETLN
	JMP I MGETLN

FOCTXT,	FILENAME FOCAL.TM	/USED BY 'GOSUB'

XGETC,	0		/ANOTHER FAKE
	CIF CDF 10
	JMS I (MGETC
	TAD I XCHAR
	CDF
	DCA CHAR
	JMP I XGETC

	PAGE

	FIELD 1
/PFOC1B -- PS/8 FOCAL MAIN INTERPRETER


/THIS VERSION OF PS/8 FOCAL WAS DERIVED FROM THE FOLLOWING
/	FOCAL-8 SOURCE:

/***********************************************************************
/DEC-8E-LFOCA-A-LA1

/OCTOBER 1971			RM/SM

/COPYRIGHT 1971 DIGITAL EQUIPMENT CORPORATION
/	MAYNARD, MASSACHUSETTS 01754

/FOCAL IS A REGISTERED TRADEMARK OF
/DIGITAL EQUIPMENT CORPORATION

/FOCAL-8 IS AN ON-LINE FORMULA CALCULATOR AND
/COMPILER FOR STATEMENTS IN ALGEBRAIC LANGUAGE
/THIS VERSION OF FOCAL-8 IS SUPPORTED ON THE PDP-8/E

/***********************************************************************

/NOTES ON LISTING COMMENTS:

/THE LIMITS OF PAGE BOUNDARY WANDERING ARE DENOTED BY:

/-------------------------------------------------------------------
/PAGE BOUNDARY
/------------------------------------------------------------------

/LOCATIONS OVERLAYED BY THE 8K OVERLAY ARE DENOTED BY     /*8K*

/PSEUDO-FLOATING POINT INSTRUCTIONS

FIXMRI FPOW=5000
FIXMRI FADD=1000
FIXMRI FSUB=2000
FIXMRI FMUL=4000
FIXMRI FDIV=3000
FIXMRI FGET=0000
FIXMRI FPUT=6000

FNOR=7000
FEXT=0
FXIT=0
FINT=JMS I 7
FENT=JMS I 7
RFC=6014
SMP=6101
KCF=6030
DCMA=6601

NEGATE=JMS I 51


	FIELD 1

/MISCELLANEOUS ITEMS
*0
ECHOP,	ECHO
P13,	13	/CONSTANT
C100,	100	/CONSTANT

/LOCATIONS 4,5,6 RESERVED FOR XODGWU

*7
	FPNT	/ADDRESS OF FLOATING POINT INTERPRETER

/AUTO-INDEX REGISTERS

AXIN,	0 	/STORAGE INDEX (LOC *10)
XRT,	0	/EXTRA XR
XRT2,	0	/EXTRA XR
PDLXR,	FEXP-1		/PUSHDOWN LIST INDEX REGISTER.
FLTXR,	0	/XR FOR FLOATING POINT
FLTXR2,	0	/EXTRA FOR F.P.
RISZ,	0	/RANDOM RANDOM #'S

TEXTP=.	/TEXT POINTERS (LOC *17)
AXOUT,	0	/OUTPUT INDEX
XCT,	0	/UNPACK SWITCH
GTEM,	0	/UNPACK STORAGE
PC,	PC0	/PROGRAM COUNTER		/*8K*

THISLN,	0	/LINE POINTER FROM 'FINDLN'
THISOP,	0	/CURRENT 'EVAL' OPERATION
LASTLN,	0	/BACK POINTER FROM 'FINDLN'
DEBGSW,	1	/DEBUG SWITCH  ; NON-ZERO FOR LITERAL.
PACKST,	0	/RUBOUT PROTECTION
PT1,	0	/VARIABLE POINTER
LASTV,	STVAR	/ADDRESS OF LAST VARIABLE	/*8K*
T1,	0	/TEMPORARY REGISTER - MAIN
T3,	0	/TEMP REGISTER FOR OUTPUT
INBUF,	0	/KEYBOARD INPUT BUFFER
BOTTOM,	FEXP-1		/LAST LOCATION CURRENTLY AVAILABLE IN FIELD ZERO
INSUB,	0	/0= GETC; #0 = READC
GOK,	GOKILL	/TO KILL 'CURRENT PROGRAM SAVED' FLAG

/  *40 = FLOATING POINT

*54

/VARIABLES   -   INITIALIZED FOR THE DIALOGUE


SORTCN,	0	/NUMBER IN TABLE FROM SORTC
LASTOP,	0	/LAST OPERATION FOR EVAL
EFOP,	0		/FUNCTION CODE.
CNTR,	-20	/DELETE AND ERROR COUNTER(USED BY F.P. ALSO)

BUFR,	LINE1	/NEXT LOCATION IN BUFFER = LAST LOCATION OF TEXT/*8K*

ADD,	XOUTL	/CHAR. BUF. IN.	 (DEBUG AIDS.SEE BELOW.)
XCTIN,	0	/PACK SWITCH
OUTDEV,	XOUTL	/POINTER TO OUT. SUB.	(OUTL)-FOR DEBUGGING
INDEV,	XI33	/POINTER TO IN. SUB.	(I33)-FOR DEBUGGING

NAGSW,	0001	/NOT ALL AND/OR GROUP SWITCH(4000=ONE;1=ALL;0=GROUP);(0000)-FOR TSS-8
CHAR,	215	/THE MOST IMPORTANT REGISTER
LINENO,	0000	/LINE NUMBER READ BY GETLN;(0400)-FOR TSS-8
GINC,	WORDS+2	/=6 FOR 4-WORD - CONSTANT

T2,	0	/TEMP REGISTER - FOR NEW INST. ROUTINES.




	*73
LIST6,	214	/F.F. (^L)
	207	/BELL
LIST7=.
P337,	337	/LEFT ARR
CLF,	212	/L.F.
LIST3=. /EXCRETION LIST
CCR,	215	/LIST BRANCHER.
DMPSW,	HLT	/(SEARCH CHARACTER)-VARIABLE
/=0000 FOR TRACE ON.


/THE REST OF PAGE ZERO IS PURE TO THE MULTI-USER SYSTEM

M100=.
P7700,	7700	/LEFT MASK
PER,	256	/PERIOD
M77,	-77	/EXTEND CODE TEST
P7600,	7600	/GROUP MASK
M20,	-20	/CONSTANT
P177,	177	/STEP MASK
P17,	17	/BCD MASK
P277,	277	/"?"
M2,	-2	/CONSTANT
MINUSA,	-301	/CONSTANT
C260,	260	/ASCII FOR ZERO
M240,	-240	/SPACE TEST
MPER,	-256	/PERIOD TEST
MCR,	-215	/C.R. TEST
MFLT,	-WORDS	/= -4 FOR 4-WORD
M5,	-5	/PAREN TEST
M11,	-11	/PAREN TEST
P77,	77	/RIGHT MASK
C200,	200	/CONSTANTS
P4000,	4000	/NAGSW TEST CONSTANT (FOR PDP-5)

FLARGP,	FLARG	/DATA ADDRESS
DOUBLE,	MULT2	/MULTIPLY FLAC BY 2
FOUTPUT,FLOUTP	/FLOATING OUTPUT
FINPUT,	FLINTP	/FLOATING INPUT
	COMBUF=.
LIBN,	LIBFIL	/COMMAND BUFFER START
CFRS,	LINE0	/ADDRESS OF DUMMY LINE

STARTV=.
END,	STVAR	/VARIABLE BUFFER START
ENDT,	LINE1	/TEXT BUFFER START
EFUN3I,	EFUN3	/FUNCTION RETURN
CFRSX,	FLTZER	/MOVED FOR ^L FUDGE


/'FINPUT' USES CHAR AND GETC OR READC TO DEVELOP 
/A NUMBER WHICH IS THEN STORED VIA PT1.

WORDS=4	/OR 3
/NEW INSTRUCTIONS:

PUSHJ=JMS I .	/RECURSIVE SUBROUTINE CALLS
	XPUSHJ
POPJ=JMP I .	/RECURSIVE RETURN
	XPOPJ
PUSHA=JMS I .	/SAVE AC
	XPUSHA
POPA=JMS I .	/RESTORE AC
	XPOPA
PUSHF=JMS I .	/SAVE FP #
	PD2
POPF=JMS I .	/RESTORE FP #
	PD3
GETC=JMS I .	/UNPACK A CHARACTER
	UTRA
PACKC=JMS I .	/PACK A CHARACTER
	PACBUF
SORTJ=JMS I .	/SORT AND BRANCH ON AC OR CHAR
	SORTB
SORTC=JMS I .	/SORT CHAR
	XSORTC
PRINTC=JMS I .	/PRINT AC OR CHAR
XPRNTC,	OUT
READC=JMS I .	/READ DATA INTO CHAR AND PRINT IT
RDIV,	CHIN
PRNTLN=JMS I .	/PRINT C(LINENO)
	XPRNT
GETLN=JMS I .	/UNPACK AND FORM A LINENUMBER
	XGETLN
FINDLN=JMS I .	/SEARCH FOR A GIVEN LINE
	XFIND
ENDLN=JMS I .	/INSERT LINE POINTERS
	XENDLN
RTL6=JMS I .	/ROTATE LEFT SIX
	XRTL6
SPNOR=JMS I .	/IGNORE SPACES AND LEADING ZEROS
	XSPNOR
TESTN=JMS I .	/PERIOD; OTHER; NUMBER
	XTESTN
TSTLPR=JMS I .	/SKIP IF 5<SORTCN<= 11 (I.E. AN L-PAR)
	LPRTST
TSTGRP=JMS I .	/SKIP IF G(AC) = G(LINENO)
	GRPTST
TESTC=JMS I .	/TERM; NUMBER; FUNCTION; LETTER- AND IGNORE SPACES.
	XTESTC
DELETE=JMS I .	/REMOVE OLD TEXT LINE
PSIN,	XDELETE
ERROR2=JMS I .	/EXCESS SOMETHING ERROR
ERROR3=JMS I .	/MISCELLANEOUS ERROR
ERROR4=JMS I .	/FORMAT ERROR
	ERR2

DPC,	PS8PC	/PC
DTHIS,	THISD	/THISLN
DPT1,	PT1D	/PT1
DXRT,	XRTD	/(TAD I XRT)
DAXIN,	AXIND	/(DCA I AXIN)
DAXOUT,	AXOUTD	/(TAD I AXOUT)
SECRTV,	STVAR	/FOR SECRET VARIABLES, OF COURSE
	RECOVR+1

/COMMAND/INPUT DRIVER

*177
START,	SKP CLA		/PROGRAM START FROM SELF
	JMP I 176	/FUDGE FOR ?00.00 PRINTOUT
	TAD C200	/INITIALIZE PC
	DCA PC		/FOR COMMAND MODE
	IAC		/USE ONE IN THE AC TO
	DCA DMPSW	/INIT UNPACK AND TRACE SWITCH
	DCA DEBGSW	/ENABLE TRACE FOR INPUT OF (?)
	TAD PUSHB	/OVERFLOW PROTECTION
	DCA PDLXR	/NO PATCH TEST
	TAD CSTAR	/TYPE * TO INDICATE COMMAND MODE
	JMS I ECHOP	/SHOULD WE PRINT A '*'?
IBAR,	TAD BUFR	/COMMAND INPUT BUFFER
	DCA AXIN	/FOR UNPACKING
	DCA XCTIN
	TAD BUFR	/RUBOUT PROTECTION
	DCA PACKST
IGNOR,	READC		/READ COMMAND STRING
	SORTJ
	LIST7-1	/MOVED DOWN ONE
	INLIST-LIST7
	PACKC		/SAVE STRING CHARACTER.
	JMP IGNOR

CSTAR,	252		/ACKNOWLEDGE CHARACTER
PUSHB,	RESTORE-1+13	/END FOR TEXT AND COMMAND INPUT

/COMMAND/INPUT PROCESSOR

IRETN,	PACKC		/START TO PACK C.R.
	PACKC		/FINISH C.R.
	TAD  BUFR		/INITIALIZE FOR UNPACKING
GONE,	DCA AXOUT	/SETUP CURRENT LINE
	DCA XCT
	GETC		/READ FIRST CHARACTER.
	TAD PUSHB1	/INIT STACK POINTER
	DCA PDLXR
	SPNOR		/IGNORE LEADING BLANKS
	TESTN		/DOES THE LINE BEGIN WITH 1-9?
	JMP GZERR	/PERIOD =ILLEGAL GROUP ZERO USAGE
	JMP INPUTX	/NO
	ISZ DEBGSW	/YES,DISABLE TRACE FOR REPACKING
	GETLN		/READ THIS LINE NUMBER
	TAD P4000	/TEST  FOR SINGLE LINE.
	TAD NAGSW
	SZA CLA
	ERROR3		/ILLEGAL LINE NUMBER ON INPUT
	TAD BUFR	/SET POINTERS
	DCA AXIN
	DCA XCTIN
	TAD LINENO	/SAVE LINE #
	JMS I DAXIN	/DCA I AXIN
	SPNOR		/IGNORE SPACES AFTER LINE NUMBER
	SKP
	GETC		/READ 1ST AFTER LINENO TERMINATOR.
SRETN,	PACKC		/SAVE TEXT AND RESTORE DATA FIELD
	TAD CHAR	/TEST FOR END OF INPUT STRING
	TAD MCR
	SZA CLA
	JMP .-5
	DELETE		/REMOVE OLD LINE, IF ANY.
	ENDLN		/INSERT NEW LINE
	JMP START	/POINTERS MUST BE REINITIALIZED
INPUTX,	PUSHJ		/PROCESS IMMEDIATE COMMAND.
	PROC
	JMS I DPC	/TAD I PC
	SNA		/END OF PROGRAM? 
	JMP START	/YES
	DCA PC		/SAVE NEW LINE NO.
	TAD PC		/START NEW LINE
	IAC
	JMP GONE	/PROCESS OTHER COMMANDS

/TEXT LINE BUFFER FORMAT*

/#1 : POINTER OR ZERO IN LAST
/#2 : LINENO
/#3 - #N+1 : TEXT
/#N : C.R.

/LINE NUMBER FORMATION

FL100,	7
	3100
	0
FLP5,	0
	2000
	0
	0
PTEMP,	ZBLOCK 4
XGETLN,	0	/COMPUTED LINE #'S
	SPNOR	/IGNORE SPACE
	TAD CHAR	/'A' IS SPECIAL
	TAD MINUSA
	SNA CLA
	JMP TESTA
	PUSHJ	/EVALUATE NUMBER OR EXPRESSION
		EVAL
	FENT
	FPUT PTEMP	/SAVE IT
	FEXT
	JMS I INTEGER		/GET GROUP PART
	TAD P7740	/CHECK IF TOO BIG
	SMA CLA
	ERROR2	/BAD GROUP #
	TAD FLAC+2	/GET GROUP AGAIN
	RTL6
	RAL
	DCA LINENO	/SAVE IT
	NEGATE
	FENT
	FADD PTEMP	/GET FRACTION
	FMUL FL100
	FADD FLP5	/ROUND UP
	FEXT
	JMS I INTEGER
	TAD LINENO	/ADD GROUP
TESTA,	DCA LINENO
	CLA CLL

	TAD LINENO	/CHECK FOR ERROR
	AND P7600
	SZA CLA
	CML
	TAD LINENO
	AND P177
	SNL SZA
GZERR,	ERROR2		/ILLEGAL GROUP ZERO USAGE
	SZA CLA		/AND SET NAGSW
	TAD P2000
	CML RAL
	DCA NAGSW
	JMP I XGETLN
PUSHB1,	3576+13
LCON,	DECONV
P7740,	7740
P2000,	2000

/RANGE OF ACCEPTABLE LINE NUMBERS = 1.01 TO 31.99
/NAGSW:

/GROUP=0000
/LINE=4000
/ALL=0001

/---------------------------------------------------------------------
/LIST OF FUNCTION ADDRESSES. (NAMES ARE IN "FNTABL")

FNTABF=.
	XABS	/FABS	-ABSOLUTE VALUE
	XSGN	/FSGN	-SIGN PART
	XINT	/FITR	-INTEGER PART
	ERROR5	/FY	(USER DEFINED)
PFRAN,	FRAN	/FRAN	-RANDOM NUMBER
	ERROR5	/FZ	(USER DEFINED)
	ARTN	/FATN	-ARCTANGENT
	FEXP	/FEXP	-E^X
	FLOG	/FLOG	-LN(X)
	FSIN	/FSIN	-SINE
	FCOS	/FCOS	-COSINE
	XSQRT	/FSQT	-SQUARE ROOT
	FIN	/CHARACTER INPUT FUNCTION
	FOUT	/CHARACTER OUTPUT FUNCTION
	FIND	/FIND FUNCTION

/-----------------------------------------------------------------------
XRTL6,	0	/ROTATE AC LEFT SIX - "RTL6"
	CLL RTL
	RTL
	RTL
	JMP I XRTL6	/--RETURN--

/RECURSIVE OPERATE, EXECUTE, OR CALL 

DO,	GETLN		/EXECUTE ONE LINE, A GROUP,OR ALL
	TAD PC		/SAVE ADDRESS
	PUSHA		/OF CURRENT LINE
	PUSHF		/SAVE REST OF THIS LINE
	TEXTP		/ADDRESS OF TEXT POINTERS
DGRP,	PUSHF		/SAVE NAGSW; CHAR; AND LINENO.
	NAGSW
	TAD NAGSW	/CHECK DATA FROM GETLN.
	SPA CLA		/SKIP IF GROUP OR ALL
	JMP DOONE	/DO ONE LINE
	FINDLN		/INIT FOR GROUP AND SET THISLN
	NOP
	TAD THISLN	/TEST FOR GOOD GROUP NUMBER.
	DCA XRT
	JMS I DXRT	/TAD I XRT	/*8K*
	TSTGRP
	ERROR2		/NO SUCH GROUP NUMBER
DGRP1,	PUSHJ		/EXECUTE OBJECT LINE AND SET PC.
	PROCESS-2
	POPF		/RESTORE THE DATA
	NAGSW
	JMS I DPC
	SNA
	JMP DCONT	/ALL DONE
	IAC
	DCA PT1		/SAVE POINTER TO LINENO
	TAD NAGSW	/CHECK FOR GROUP
	SMA SZA CLA
	JMP .+4		/DO ALL
	JMS I DPT1	/TAD I PT1
	TSTGRP
	JMP DCONT	/NOT IN GROUP
	JMS I DPT1	/TAD I PT1
	DCA LINENO
	JMP DGRP	/CONTINUE THE SUBROUTINE

DOONE,	FINDLN		/FIND THE LINE
	ERROR2		/NO SUCH LINE NUMBER
	PUSHJ		/EXECUTE IT
	PROCESS
	POPF		/RESTORE CHAR
	NAGSW
DCONT,	POPF		/RESTORE TEXT POINTERS
	TEXTP
	POPA		/RESTORE ADDRESS OF CURRENT LINE.
	DCA PC
	JMP I .+1	/CONTINUE PROCESSING THIS LINE.
	PROC

/PUSHDOWN LIST CONTROLS

PD2,	0		/PUSHDOWN THE AC - "PUSHA"
	TAD I PD2
	ISZ PD2
	DCA .+3
	CIF
	JMS I .+3
	0
	JMP I PD2
	MPD2

PD3,	0
	TAD I PD3
	DCA .+4
	ISZ PD3
	CIF
	JMS I .+3
	0
	JMP I PD3
	MPD3

XPOPA,	0
	CIF
	JMS I .+2
	JMP I XPOPA
	MPOPA

ZSERCH,	TAD STARTV
	TAD Z3
	DCA PT1		/POINT TO MANTISSA
	TAD LASTV	/CHECKED ALL VARIABLES FOR 0?
	CLL CIA
	TAD PT1
	SZL CLA
	JMP ZERROR	/FAKE ERROR MESSAGE (NO CHANGE FROM FOCAL)
	TAD I PT1	/ IS THIS VARIABLE = 0?
	SNA CLA
	JMP I ZFOUND	/YES, CHANGE ITS NAME
	TAD PT1		/NO, CHECK THE NEXT
	TAD GINC
	JMP ZSERCH+2

ZERROR,	TAD Z1467	/FAKE ERROR ADDRESS (+1)
	DCA I 166	/(ERROR2-JMS I 0)
	JMP I 166	/KLUDGE

Z1467,	1467
Z3,	3
ZFOUND, ZERFND


FIND,	TAD XFIND1	/SETUP 'READC' EXIT
	DCA I RDIV
	JMS I INTEGER		/FIX ARG
	CLA
FIND1,	JMS I INDEV	/GET THE NEXT CHAR
	DCA CHAR	/SAVE IT
	TAD CHAR
	CIA		/IS IT THE ONE WE WANT?
	TAD FLAC+2
	SZA CLA
	JMP I XCHIN	/GO FINISH 'READC' (ECHO)
	JMP I EFUN3I

XFIND1,	FIND1
XCHIN,	CHIN+3


/--------------------------------------------------------------------

INLIST=.	/INPUT CONTROL CHARACTERS
	IBAR		/B.A. = RESTART
	IGNOR		/L.F. = IGNORE
	IRETN		/C.R. = TERMINATE STRING

FLIST2,	FLIMIT		/,=STANDARD
	FINFIN		/;=SHORT
	ERROR5		/CR=DUMB

FLIST1,	FINCR		/,=STANDARD FORMAT
	PROCESS		/;=SET;PLUS ,..
	PC1		/C.R.=SET COMMAND.

MF,	-306		/USED BY TESTC


/PRIMARY CONTROL AND TRANSFER

GOTO,	GETLN		/READ THE LINE NUMBER REQUESTED
	FINDLN		/LOCATE IT AND RESET TEXTP
	ERROR2		/NOT THERE
	TAD THISLN	/SET PC
	DCA PC
/---------------------------------------------------------------------
PROCESS,GETC		/TEST FOR END OF LINE
PROC,	TAD CHAR	/FIRST CHARACTER READY = USE PROC
	TAD MCR
	SNA CLA
PC1,	POPJ		/EXIT "PROCESS"
	SORTC		/IGNORE "SPACE",",", AND ";".
	GLIST-1
	JMP PROCESS
	TAD CHAR	/SAVE COMMAND CHARACTER
	AND P337	/EXECUTE LOWER CASE ALSO
	PUSHA
	GETC		/GO TO TERMINATOR
	SORTC
	GLIST-1
	SKP
	JMP .-4
	JMS I PXKSF
	POPA
	SORTJ		/GO DO COMMAND
	COMLST-1
	COMGO-COMLST
	ERROR2		/ILLEGAL COMMAND

PXKSF,	XKSF		/ADDRESS OF KBD BREAK CHECK

COMMENTS=PC1		/ALSO IS CONTINUE

/OUTPUT COMMAND TEXT

WRITE,	GETLN		/SET LINENO
	ISZ DEBGSW	/DISABLE TRACE
	FINDLN		/SEARCH FOR LINE NUMBER
	JMP WTESTG	/NOT THERE OR GROUP
	TAD LINENO
	SZA CLA
	PRNTLN		/PRINT LINE NUMBER AND A SPACE.
	GETC
	PRINTC		/PRINT TEXT OF A LINE.
	TAD CHAR
	TAD MCR
	SZA CLA		/SKIP IF END OF LINE
	JMP .-5
	JMS I DTHIS	/TAD I THISLN
WTEST2,	SNA
	JMP WX-2
	IAC
	DCA PT1		/SAVE POINTER TO LINENO OF NEXT
	TAD NAGSW
	SMA CLA
	JMS I DPT1	/TAD I PT1
	TSTGRP		/TRY NEXT LINENO FOR GROUP.
	JMP WX
WALL,	JMS I DPT1	/TAD I PT1
	DCA LINENO
	JMP WRITE+2
WTESTG,	TAD THISLN	/INIT GROUP PRINTOUT
	JMP WTEST2
	DCA DEBGSW
	POPJ
WX,	TAD NAGSW
	SPA SNA CLA	/SKIP IF ALL
	JMP WX-2
	PRINTC		/PRINT C.R. AGAIN
	JMP WALL


XTESTC,	0	/TEST THE NATURE OF THE NEXT ALPHANUMERIC - "TESTC"
	SPNOR		/IGNORE SPACES
	SORTC		/TEST THE VARIABLE TERMINATORS
	TERMS-1
	JMP I XTESTC	/YES - SORTCN IS SET--RETURN--
	TAD CHAR	/NO
	ISZ XTESTC
	TAD MF
	SNA CLA		/TEST FOR "F"
	JMP XT3
	TESTN
	JMP I XTESTC	/.--RETURN--
	SKP		/OTHER
	JMP I XTESTC	/NUMBER--RETURN--
	ISZ XTESTC
XT3,	ISZ XTESTC	/RETURNS:T;N;F;A
	JMP I XTESTC	/--RETURN--

XSORTC,	0	/SORT CHAR AGAINST TABLE - "SORTC"
	TAD I XSORTC
	DCA XRT2	/1ST ARG IS LIST-1
	TAD I XRT2
	SPA		/LIST IS ENDED BY A NEGATIVE NUMBER
	JMP SEXC	/2AND EXIT = NOT IN LIST
	CIA
	TAD CHAR
	SZA CLA		/COMPARE
	JMP .-6
	TAD I XSORTC	/COMPUTE INCREMENT : 0 - N
	CMA
	TAD XRT2
	DCA SORTCN
	SKP		/1ST EXIT = YES
SEXC,	ISZ XSORTC
	ISZ XSORTC
	CLA CLL
	JMP I XSORTC	/--RETURN--


GRPTST,	0	/AC VS LINENO - "TSTGRP"
	AND P7600
	CIA
	DCA T2
	TAD LINENO
	AND P7600
	TAD T2
	SNA CLA
	ISZ GRPTST
	JMP I GRPTST	/--RETURN--

/INPUT FROM TEXT OR KEYBOARD;
/IF BACK-ARROW, RESTART INPUT

INPUT,	0		/INPUT A CHARACTER
	TAD INSUB	/NON-ZERO FOR KEYBOARD
	SZA CLA
	JMP .+3
	GETC
	JMP I INPUT	/--RETURN--
	READC
	SORTJ
	SPECIAL-1
	INFIX-SPECIAL
	JMP I INPUT	/--RETURN--

/----------------------------------------------------------------------
ILIST,	IF1		/,
	PROCESS		/;
	PC1		/CR

		/ENGLISH-FRENCH
COMLST=.	/COMMAND DECODING LIST
	323	/SET 	- ORGANIZE
	306	/FOR 	- QUAND
	311	/IF 	- SI
	304	/DO 	- FAIZ
	307	/GOTO 	- VA
	303	/COMMENT- COMMENTE
	301	/ASK 	- DEMANDE
	324	/TYPE 	- TAPE
	314	/LIBRARY- ENTREPOSE
	305	/ERASE 	- BIFFE
	327	/WRITE 	- INSCRIS
	315	/MODIFY	- MODIFIE
	321	/QUIT 	- ARRETE
	322	/RETURN	- RETOURNE
	"O		/ADD 'OPEN' COMMAND

/THIS COMMAND LIST IS SPEED OPTIMIZED.


/CONDITIONAL TRANSFER PROCESS.

IF,	TESTC		/IGNORE SPACES AND TEST
/---------------------------------------------------------------------
	JMS I IECALL	/T
	POPA 		/N-DUMP THE (EFOP)
	JMS I IPART	/F-CHECK FOR PAREN MATCH
	TAD M2		/A
	DCA T1
	TAD FLAC+1	/TEST -,0,+
	SPA
	ISZ T1		/N-TO 	-1,-2,-3
	SPA SNA CLA
IF3,	ISZ T1		/COUNT COMMAS
	SKP
	JMP I COMGO+4	/TRANSFER
	SORTJ		/SEARCH TEXT UNTILL ,;C.R.
	TLIST-1
	ILIST-TLIST
	GETC
	JMP .-4
IF1,	GETC		/MOVE PAST COMMA 
	JMP IF3
IECALL,	ECALL
IPART,	PARTEST

/LOOP CONTROL STATEMENT

SET=.			/SUBSET OF "FOR".

FOR,	PUSHJ		/LOOPS, ETC.
	GETARG		/LOOK FOR "=" NEXT
	SPNOR		/IGNORE SPACES
	TAD CHAR
	TAD MEQ
	SZA
	ERROR4		/LEFT OF "=" IN ERROR: 'FOR' OR 'SET'
	TAD PT1
	PUSHA		/SAVE POINTER TO VARIABLE
	PUSHJ
	EVAL-1		/GET INITIAL VALUE EXPRESSION
	POPA
	DCA PT1
	FINT		/INITIALIZE NOW.
	FPUT I PT1
	FXIT
	SORTJ		/TEST LAST CHAR FROM "EVAL"
	TLIST-1
	FLIST1-TLIST
	ERROR4		/EXCESS R-PAR
FINCR,	TAD PT1		/SAVE VARIABLE ADDRESS *
	PUSHA
	PUSHJ		/EVALUATE THE INCREMENT,IF ANY.
	EVAL-1
	SORTJ		/TEST TERMINATORS
	TLIST-1
	FLIST2-TLIST
	ERROR4		/ILLEGAL TERMINATOR IN 'FOR'
FLIMIT,	PUSHF		/SAVE THE INCREMENT.	*
	FLARG
	PUSHJ		/GET THE LIMIT(NO ERROR DETECTION AFTER LIMIT)
	EVAL-1
FCONT,	PUSHF		/SAVE THE LIMIT *
	FLARG
	PUSHF		/SAVE TEXT OF OBJECT STATEMENTS
	TEXTP
	PUSHJ		/DO THE OBJECT STATEMENTS
	PROCESS
	POPF		/RESTORE REMAINING TEXT.
	TEXTP
	POPF		/GET LIMIT
	FLARG
	POPF		/GET INCREMENT
	ITER1
	POPA		/GET VARIABLE ADDRESS
	DCA PT1
	FINT		/INCREMENT AND TEST
	FGET I PT1	/LOAD THE VARIABLE
	FADD I FINKP	/INCREMENT IT
	FPUT I PT1	/CHANGE IT
	FSUB I FLARGP	/TEST IT
	FXIT
	TAD FLAC+1
	SMA SZA CLA
	POPJ		/END OF LOOP
	TAD PT1
	PUSHA		/SAVE ADDRESS *
	PUSHF		/SAVE INCREMENT AGAIN *
FINKP,	ITER1
	JMP FCONT
MEQ,	-275
MCOM,	-254
FINFIN,	PUSHF		/SET INCREMENT TO ONE.
	FLTONE	/MOVED FOR ^L FUDGE
	JMP FCONT



SORTB,	0	/SORT AND BRANCH ROUTINE. - "SORTJ"
	SNA
	TAD CHAR	/ASSUME CHAR IF AC=0
	CIA
	DCA T2		/SAVE SORT ITEM
	TAD I SORTB	/FIRST ARG IS LIST LESS ONE
	ISZ SORTB	/2AND IS INTRA-LIST LENGTH
	DCA XRT2
	TAD I XRT2
	SPA		/**LISTS ENDED BY NEGATIVE NUMBERS**
	JMP SEX		/READ EXIT
	TAD T2		/FIND ADDRESS
	SZA CLA
	JMP .-5
	TAD XRT2	/MATCH FOUND.
	TAD I SORTB
	DCA T2
	TAD I T2
	DCA T2		/DEBUG : AC = ADDRESS
	JMP I T2
SEX,	ISZ SORTB	/MATCH NOT FOUND.
	CLA CLL
	JMP I SORTB	/--RETURN--
COMGO=.	/COMMAND ROUTINE ADDRESSES
	SET
	FOR
	IF
	DO
	GOTO		/(REFERENCED)
	COMMENT
	ASK
	TYPE
	LIB
	ERASE
	WRITE
	MODIFY
	START	/RETURN TO COMMAND MODE VIA 'QUIT'
	RETRN	/MOVE 'RETURN'
	FILER	/ADD 'OPEN'





/---------------------------------------------------------------------
/INPUT-OUTPUT STATEMENTS

ATSW,	0		/ASK-TYPE SWITCH
ASK,	CLA CMA		/REMEMBER WHICH CALL.
TYPE,	DCA ATSW
TASK,	SORTJ		/SPECIAL CHARACTER? 
	ALIST-1
	ATLIST-ALIST
	ISZ ATSW	/TEST QUOTE SWITCH
	JMP TYPE2
	PUSHJ		/DO ASK; SETUP PT1
	GETARG
	TAD CHAR	/SAVE IN-LINE CHARACTER.
	PUSHA
	CLA CLL	/DON'T PRINT COLON
	NOP
	ISZ INSUB	/INDICATE 'READC'
	IAC		/POINT PAST CHAR
	JMS I FINPUT	/READ DATA AND SAVE
	POPA		/RE-TEST LAST TERMINATOR
	DCA CHAR
	JMP ASK		/CONTINUE PROCESSING

TYPE2,	PUSHJ		/DO TYPE
	EVAL
	JMS I FOUTPUT	/PRINT
	JMP TYPE
TQUOT,	ISZ DEBGSW	/DISABLE TRACE
	GETC		/TYPE LITERALS
	SORTJ
	TLIST2-1
	TLIST3-TLIST2
	PRINTC
	JMP TQUOT+1
TINTR,	GETC		/PASS PERCENT SIGN
	GETLN		/READ FORMAT CONTROL: "%7.03"
	TAD LINENO
	DCA FISW	/SAVE FORMAT CODE
	JMP TASK
TCRLF2,	TAD P15	/PRINT CR ONLY
	PRINTC		/(PRINTC HANDLES NULL FOR DELAY!)
	JMP .+3
TCRLF,	TAD CCR		/EXCLAMATION POINT=CR,LF.
	PRINTC
TASK4,	DCA DEBGSW	/RE-ENABLE THE TRACE
	GETC		/MOVE TO NEXT CHARACTER
	JMP TASK
P15,	15		/":"

TTAB,	PUSHJ		/TAB ARGUMENT IN ASK OR TYPE
		EVAL-1
	FENT
	FADD I TRND	/LET'S ROUND OFF
	FEXT
	JMS I INTEGER
	CIA
	TAD TABC
	IAC
	SMA
	JMP PBACK
	DCA CNTRX
	TAD SPACE
	PRINTC
	ISZ CNTRX
	JMP .-3
PBACK,	CLA CLL
	JMP TASK

TABC,	0
CNTRX,	0
TRND,	FLP5
SPACE,	240



/IF DEBGSW=0 : ENABLE FLIP-FLOP "DMPSW"
/	#0: DISABLE AND RETURN ALL"?" ' S.
/IF DMPSW = 0: TRACE ON, IF ENABLED
/	#0: TRACE OFF
/IF BOTH = 0 : PRINT TRACE.
/SEARCH ROUTINES

MODIFY,	GETLN		/READ LINE NO.
	FINDLN		/LOOK IT UP NOW.
	ERROR2		/NOT THERE = BAD COMMAND UNLESS ZERO.
	TAD BUFR	/SET POINTERS
	DCA AXIN	/FOR INPUT
	DCA XCTIN
	TAD LINENO	/COPY THE SAME LINE NUMBER.
	JMS I DAXIN	/DCA I AXIN
	TAD AXIN	/SAVE START OF NEW LINE
	DCA PACKST
SCONT,	JMS I INDEV	/READ THE TELETYPE INPUT SILENTLY.
	DCA LIST3+1	/SAVE SEARCH CHARACTER
	ISZ DEBGSW	/NO BREAKS.
SCHAR,	GETC		/TYPE+TEST-F.F.
	PRINTC		/PLAYBACK THE TEXT
	SORTJ		/LOOK FOR MATCH
	LIST3-1
	LISTGO-LIST3	/LISTGO HAS MOVED
	PACKC		/SAVE NEW LINE.
	JMP SCHAR
SBAR,	TAD BUFR	/RESTART-B.A.
	IAC
	DCA AXIN	/SET POINTERS
	DCA XCTIN
SFOUND,	READC		/READ FROM KEYBOARD
	SORTJ		/TEST
	LIST6-1
	SRNLST-LIST6
SGOT,	PACKC		/PACK CHAR.
	JMP SFOUND	/MORE
/TAKE THE INTEGER PART

XINT,	JMS I INTEGER	/(FIX)
	CLA
	JMP I EFUN3I

XPUSHA,	0
	CIF
	JMS I .+2
	JMP I XPUSHA
	MPUSHA




/----------------------------------------------------------------------
SRNLST=.	/'MODIFY' CONTROL CHARACTER TABLE
	SCHAR	/F.F. = CONTINUE
	SCONT	/BELL = CHANGE SEARCH CHARACTER
	SBAR	/B. A. = RESTART
	SCONT+1	/L.F. = FINISH THE LINE
LISTGO,	SRETN	/C.R. = END THE LINE HERE AS IS
	SGOT	/CHAR = SEARCH CHAR.





/ ASK/TYPE LIST OF CONTROLS.
ALIST,	":
	245	/%
	242	/"
	241	/!
	243	/#
	244	/$
GLIST=.
	240	/SPACE
TLIST=.
	254	/,
	273	/;
	215	/C.R.
/THIS LIST IS ENDED BY 'TESTC'.

/FIND OR ENTER A VARIABLE IN THE LIST.

GETARG,	TESTC		/FIRST LETTER OF ARG
TLIST2,	0242		/"
	0215		/C.R. - FUNCTION OR NUMBER IS NOT AN ARG.
	ERROR4		/BAD ARGUEMENT IN 'FOR', 'SET', OR 'ASK'
GETVAR,	DCA XCTIN	/RESET PACK SWITCH
	PACKC		/PACK FIRST CHAR
	TAD ADD		/SAVE NAME
	DCA EFOP	/WHERE WE CAN PUSH IT
GETLP,	GETC		/GET NEXT CHAR
	SORTC		/END OF NAME?
		TERMS-1
	JMP GSERCH	/YES
	ISZ XCTIN	/IS THIS THE SECOND CHAR
	JMP GETLP	/MORE THAN 2 CHARS, IGNORE IT
	TAD CHAR	/PACK SECOND CHAR
	AND P77		/MASK IT
	JMP GETLP-2	/ADD TO NAME
GSERCH,	TSTLPR		/CHECK FOR SUBSCRIPT
	JMP GS1
	JMS I GECALL	/PICK IT UP
	POPA		/RESTORE NAME
	DCA EFOP
	JMS I PTEST	/CHECK PAREN MATCH
	JMS I INTEGER		/CONVERT IT
GS1,	DCA SUBS	/SAVE SUBSCRIPT
	TAD EFOP	/MAKE SURE IT'S FOUND
	DCA I LASTV
	TAD SECRTV	/SEARCH STARTS WITH SECRET VARIABLES
GLOOP,	DCA PT1
	TAD EFOP	/IS THIS THE ONE?
	CIA
	TAD I PT1
	SNA CLA
	JMP CHKVAR	/MATCHED - CHECK SUBSCRIPT
NXTVAR,	TAD PT1		/NO MATCH - BUMP POINTER
	TAD GINC
	JMP GLOOP	/TRY AGAIN
CHKVAR,	ISZ PT1		/BUMP TO SUBSCRIPT
	TAD PT1		/CHECK IF IT'S REALLY THERE
	CLL CIA
	TAD LASTV
	SNL CLA
	JMP MAKVAR	/NO - IT WAS THE DUMMY
	TAD SUBS	/CHECK THE SUBSCRIPT
	CIA
	TAD I PT1


GLOOP1,	ISZ PT1		/POINT TO DATA (IN CASE IT'S NEEDED)
	SNA CLA		/SUBSCRIPT MATCH?
	POPJ		/YES!
	CLA CLL CMA RAL	/SET AC=(-2)
	JMP NXTVAR	/AND BUMP POINTER
MAKVAR,	TAD BOTTOM	/CHECK FOR OVERFLOW
	CLL CIA
	TAD LASTV
	TAD P13
	SZL CLA
	JMP I ZERSCH	/GO REPLACE A ZERO VARIABLE
	TAD LASTV	/ADD ANOTHER VARIABLE
	TAD GINC
	DCA LASTV
MAKV1,	TAD PT1		/SAVE POINTER
	DCA XRT
	TAD SUBS	/INSERT SUBSCRIPT
	DCA I PT1
	DCA I XRT	/ZERO OUT DATA
	DCA I XRT
	DCA I XRT
VARPCH,	DCA I XRT	/(NOP) - FOR 3-WORD
	JMP GLOOP1
ZERFND,	CLA CLL CMA RTL	/SET PT1 TO START OF VARIABLE
	TAD PT1
	DCA PT1
	TAD EFOP	/REPLACE THE NAME
	DCA I PT1
	ISZ PT1		/POINT TO SUBSCRIPT
	JMP MAKV1	/AND FINISH UP



SUBS=.
XSPNOR,	0		/IGNORE LEADING SPACES - "SPNOR"
	TAD CHAR
	TAD M240
	SZA CLA
	JMP I XSPNOR	/--RETURN--
	GETC
	JMP XSPNOR+1


M260,	-260
M271,	-271



SP,	240
	LIB+1
ZERSCH,	ZSERCH		/POINTER TO ERO SEACH
XTESTN,	0		/RETURNS: .; OTHER; NUMBER - "TESTN"
	TAD CHAR
	TAD MPER
	SZA CLA
	ISZ XTESTN
	TAD CHAR
	TAD M260
	DCA SORTCN	/SAVE VALUE OF THE NUMBER
	TAD SORTCN	/TEST IF REALLY A DIGIT.
	SPA CLA
	JMP I XTESTN	/--RETURN--
	TAD CHAR
	TAD M271
	SPA SNA CLA
	ISZ XTESTN	/IF A NUMBER
	JMP I XTESTN	/--RETURN--
LGOSUB,	PUSHJ		/EXECUTE SUBROUTINE
		DO+1
	TAD SP		/LIBRARY 'SPACE' = LIBRARY RETURN!
	DCA CHAR
	JMP I SP+1	/SKIP 'SPNOR'
GECALL,	ECALL
RETRN,	TAD C200
	DCA PC

/EXIT FROM A "DO" SUBROUTINE


XPOPJ,	POPA
	DCA T2
	JMP I T2
PTEST,	PARTEST		/USE THAT FREE LOCATION



/ASK-TYPE CONTROL CHARACTER TABLE
ATLIST,	TTAB
	TINTR	/% - FORMAT DELIMITER
	TQUOT	/" - LITERAL DELIMITER
	TCRLF	/! - CARRIAGE RETURN AND LINE FEED
	TCRLF2	/# - CARRIAGE RETURN ONLY
	TDUMP	/$/- DUMP THE SYMBOL TABLE CONTENTS
	TASK4	/SP- TERMINATOR FOR NAMES
	TASK4	/, - TERMINATOR FOR EXPRESSIONS
	PROCESS	/; - TERMINATOR FOR COMMANDS
	PC1	/C.R. - TERMINATOR FOR STRINGS

/$ - FOR 'TDUMP' TERMINATES THE COMMAND.


*1601

/EVALUATE AN EXPRESSION WHICH
/TERMINATES WITH AN R-PAR,; OR C.R. AND
/LEAVE THE RESULT IN FLAC AND IN FLARG.




/----------------------------------------------------------------------
ECALL,	0	/RECURSIVE CALL TO "EVAL"
	TAD SORTCN	/SAVE 'SORTCN','LASTOP',AND 'EFOP'
	PUSHA
	TAD LASTOP
	PUSHA
	TAD EFOP	/SAVE FUNCTION CODE.
	PUSHA
	TAD ECALL	/RETURN TO CALLING
	PUSHA		/ADDRESS AFTER NEXT POPJ

	GETC		/MOVE PAST EXTRA CHARACTER
EVAL,	DCA LASTOP	/EVAUATION CONTROLLER (CHECKPOINT ?)
	TESTC		/TEST CHARACTER AND IGNORE SPACES
	JMP ETERM1	/TERMINATOR
	JMP ENUM	/NUMBER
	JMP EFUN	/FUNCTION
	PUSHJ		/LETTER OF VARIABLE
	GETVAR		/FIND OR CREATE VARIABLE;ALSO SET PT1.
OPNEXT,	TESTC		/PT1=>ARG
	JMP ETERMN	/T
ECHOLST,0212		/N-ERROR IN FORMAT
	0377		/F
	JMP ETERM+1	/'EVAL' FOUND A TERMINATOR WHICH WAS NOT
			/END OF EXPRESSION (NOT ERROR!)
ETERM1,	TAD CFRSX	/SET PT1.
	DCA PT1		/TO POINT TO ZERO
	TAD M2		/TEST FOR UNARY OPERATIONS
	TAD SORTCN
	SNA
	JMP ETERM	/CREATE DUMMY FOR UNARY MINUS
	IAC
	SNA CLA
	JMP ARGNXT	/IGNORE UNARY PLUS
	TAD SORTCN	/TEST FOR NULL PARENS.
	TAD M11
	SPA CLA
	JMP ELPAR	/MIGHT BE AN L-PAR.
ETERMN,	TSTLPR
	SKP
	ERROR4		/OPERATOR MISSING BEFORE PAREN
ETERM,	TAD SORTCN	/SET FROM "TESTC"-"SORTC"
	DCA THISOP
	TAD THISOP
	TAD M11
	SMA CLA		/END?
	DCA THISOP	/"THISOP" EQUIV. TO END OF EXP.

ETERM2,	TAD THISOP	/COMPARE PRIORITIES
	CIA
	TAD LASTOP
	SPA CLA
	JMP EPAR	/CONTINUE
	TAD LASTOP	/FIND OPERATION
	CLL RTR
	RTR
	TAD OPTABL
	DCA FLOP
	TAD LASTOP
	SZA CLA		/TEST FOR END OF DATA INTO FLOATING AC.
	POPF		/GET LAST DATA
	FLAC
	FINT
FLOP,	00		/(FLOPR I PT1)+-*/
	FPUT I FLARGP	/SAVE RESULT
	FXIT
	TAD FLARGP
	DCA PT1
	TAD THISOP
	TAD LASTOP	/=0?
	SNA CLA
	POPJ		/EXIT "EVAL"
	POPA		/GET PRIOR OP
	DCA LASTOP
	JMP ETERM2	/COMPARE THIS OP
EPAR,	TSTLPR		/TEST FOR SUB-EXPRESSION
	SKP
	JMP EPAR2	/GO EVALUATE EXPRESSION
	TAD LASTOP	/CONTINUE READING THE EXPRESSION
	PUSHA		/SAVE "LASTOP".
	TAD PT1
	DCA .+2
	PUSHF		/SAVE LAST ARGUMENT
	00
	TAD THISOP	/MORE TO COME
	DCA LASTOP
ARGNXT,	GETC		/READ 1ST CHAR OF AN ARG.
	TESTC		/DO SPECIAL CHECK
	JMP ELPAR	/COULD BE LEFT PAREN
	JMP ENUM	/N
	JMP EFUN	/F
	JMP OPNEXT-2	/L
OPTABL,	FGET I PT1	/BASE FOR OPERATION COMPUTATION

ENUM,	PUSHF		/TO PROCESS A NUMBER,SAVE AC
	FLAC
	TAD FLARGP	/SET POINTER AS FOR A VARIABLE.
	DCA PT1
	DCA INSUB	/POINT TO 'GETC' AND USE CHAR
	JMS I FINPUT	/READ TEXT NUMBER => (PT1)
	POPF		/RESTORE THE AC
	FLAC
	JMP OPNEXT	/CONTINUE
EFUN,	DCA EFOP	/SET CODE
	GETC		/READ FUNCTION NAME.(1,2,OR 3 LETTERS)
	SORTC		/LOOK FOR TERMINATION CHARACTER.
	TERMS-1
	JMP EFUN2	/YES
	TAD EFOP	/NO
	CLL RAL		/MISH-MASH HASH CODE
	TAD CHAR
	JMP EFUN
EFUN2,	TSTLPR
	ERROR4		/MUST BE FOLLOWED BY PARENS TO SET ARGUMENT
	JMS ECALL	/CALL "EVAL" TO COMPUTE ARGUMENT
	POPA		/BRANCH ON FUNCTION CODE;RETURN VIA EFUN3I.
	SORTJ
	FNTABL-1
	FNTABF-FNTABL
ELPAR,	TSTLPR		/LEFT PAREN OR FELL THROUGH FUNCTION TABLE
	ERROR4		/DOUBLE OPERATORS OR ILLEGAL FUNCTION NAME.
EPAR2,	JMS ECALL	/EVALUATE NESTED EXPRESSION
/--------------------------------------------------------------------
	POPA		/DUMP EXTRA ARG.
	JMP I EFUN3I

TERMS=.		/TERMINATOR TABLE FOR 'EVAL' AND 'GETVAR'
	240		/SPACE	0
	253		/+	1
	255		/-	2
	257		//	3
	252		/*	4
	336		/UP ARR	5
	250		/(	6 L-PARS
	333		/[	7
	274		/<	10
	251		/)	11 R-PARS
	335		/]	12
	276		/>	13
	254		/,	14
	273		/;	15
	215		/C.R.	16
	275	/= TO END GETARG FROM 'SET'



GOKILL,	CDF
	DCA I LIBN	/ZERO 'CURRENT PROGRAM SAVED' FLAG
	CDF 10
	JMP START
/-----------------------------------------------------------------------
XABS,	TAD FLARG+1	/TAKE ABSOLUTE VALUE OF FLAC
	SPA CLA		/SKIP TO CONTINUE
	JMS I MINSKI	/NEGATE THE FLOATING AC

/CONTINUATION OF FUNCTION CALLS.

EFUN3,	FINT
	FNOR		/NORMALIZE FUNCTION RETURN
	FPUT FLARG	/SAVE FUNCTION VALUE
	FXIT
	TAD FLARGP	/SET POINTER
	DCA PT1
	JMS PARTEST
	JMP I .+1	/FUNCTION RETURN IS OK
	OPNEXT


FLARG,	0	/DATA TEMPORARY STORAGE
	0
	0
	0

P3,	3
LPRTST,	0		/SKIP IF LEFT PAREN. - 'TSTLPR'
	TAD SORTCN
	TAD M11
	SMA CLA
	JMP I LPRTST	/--RETURN--
	TAD SORTCN
	TAD M5
	SMA SZA CLA
	ISZ LPRTST
	JMP I LPRTST	/--RETURN--

PARTEST,0		/TEST THE PAREN MATCHINGS
	POPA		/RESTORE LAST OPERATION
	DCA LASTOP
	POPA		/REVERSE THESE TWO INSTRUCTIONS
	TAD P3
	CIA		/CHECK FOR PAREN MATCH.
	TAD SORTCN	/(STILL SET FROM THE LAST "EVAL")
	SZA CLA		/SKIP IF MATCH	
	ERROR4		/PAREN ERROR
	GETC		/MOVE PAST R-PAR
	JMP I PARTEST	/--RETURN--

/THE DELETE A LINE ROUTINE

XDELETE,0		/UNCHAIN A LINE AND RECOVER THE SPACE.
	FINDLN		/SETS "THISLN" AND "LASTLN".
	JMP I XDELETE	/ALREADY GONE --RETURN--
	ISZ DEBGSW	/DISABLE TRACE
	GETC		/MEASURE LENGTH
	TAD CHAR
	TAD MCR
	SZA CLA
	JMP .-4
	TAD AXOUT	/SAVE LAST ADDRESS
	CMA
	TAD THISLN
	DCA CNTR	/LENGTH < 0
	TAD CFRS	/IT IS ILLEGAL TO DELETE THE FIRST LINE
	CIA
	TAD THISLN
	SNA CLA
	JMP START	/JUST IGNORE SUCH COMMANDS
	CDF		/CHANGE DATA FIELD FOR 'DELETE'
	TAD I THISLN	/DISCONNECT
	DCA I LASTLN
	TAD CFRS	/START LIST AT TOP
DOK,	DCA T2		/EXAMINATION ADDRESS
	TAD I T2	/GET THE NEXT ADDR.
	SNA		/TEST FOR END
	JMP DONE	/YES-WRAP UP ALL.
	DCA T1		/SAVE NEXT ADDRESS.
	TAD THISLN	/COMPARE LINE POSITIONS
	CIA CLL
	TAD T1
	SZL CLA		/SKIP IF THISLN > X
	TAD CNTR	/CHANGE (X) TO ACCOUNT FOR
	TAD T1		/GARBAGE COLLECTION.
	DCA I T2
	TAD T1		/GET NEXT
	JMP DOK

/GARBAGE COLLECTION

DONE,	CMA		/BACKUP L FOR XR
	TAD THISLN
	DCA XRT
	TAD CNTR	/SETUP END OF HOSE
	CMA
	TAD THISLN
	DCA XRT2
	TAD CNTR	/CORRECT END OF BUFFER POINTER.
	TAD BUFR
	DCA BUFR
	TAD AXIN	/COMPUTE COUNT
	CMA
	TAD XRT2
	DCA T1
	TAD AXIN
	TAD CNTR
	DCA AXIN
	TAD I XRT2	/SIPHON LOWER PART.
	DCA I XRT
	ISZ T1
	JMP .-3
	JMP XDELETE+1	/RESET 'LASTLN','THISLN', AND DATA FIELD.


CHIN,	0		/READ IN A CHARACTER SUBR. - "READC"
	JMS I INDEV
	DCA CHAR
	SORTJ		/USE 'SORTJ' INSTEAD OF 'SORTC'
		ECHOLST-1	/SO 'SORTCN' DOESN'T GET KILLED
		ECHOGO-ECHOLST
PPRNT,	PRINTC		/ECHO THE INPUT
	JMP I CHIN	/--RETURN--
/-------------------------------------------------------------------


FNTABL=.
	2533	/FABS
	2650	/FSGN
	2636	/FITR
	0331	/FY
	2630	/FRAN
	0332	/FZ
	2572	/FATN
	2624	/FEXP
	2625	/FLOG
	2654	/FSIN
	2575	/FCOS
	2702	/FSQT
	1140		/FIN
	2672		/FOUT
	2604		/FIND

/ERASE SINGLE LINES, GROUPS, OR VARIABLES

ERASE,	TESTC		/TEST THE SECOND WORD, IF ANY.
/---------------------------------------------------------------------
	JMP ERVX	/ERASE VARIABLES
	JMP ERL		/LINES OR GROUPS
	JMP .+4		/ERROR
	TAD CHAR	/ALL TEXT
	TAD MINUSA
	SZA
	ERROR3		/BAD ARG FOR ERASE.
ERT,	TAD ENDT	/ERASE ALL TEXT **
	DCA BUFR
	CDF
	DCA I CFRS	/ERASE ALL TEXT
	JMP I GOK
	JMP START	/POINTERS MAY BE DIFFERENT NOW.
ERL,	GETLN		/ERASE LINES.
	TAD BUFR	/PROTECT REST OF TEXT.
	DCA AXIN
ERG,	DELETE		/EXTRACT ONE LINE
	ISZ THISLN
	TAD NAGSW
	SMA CLA
	JMS I DTHIS	/TAD I THISLN
	TSTGRP		/DONE ERASING GROUP?
	JMP I GOK	 /YES, ERASE 'CURRENT PROGRAM SAVED' FLAG
	JMS I DTHIS	/TAD I THISLN
	DCA LINENO
	JMP ERG
ERVX,	TAD END		/ZERO VARIABLES (BUT NOT SECRET VARIABLES)
	DCA LASTV
	POPJ


/ROUTINE CALLED VIA "FINDLN":

/SEARCH FOR A GIVEN LINE I.D. =[ "LINENO" ]
/1ST RETURN IF NOT FOUND,
/2AND IF FOUND.
/"THISLN" = FOUND LINE OR NEXT LARGER.
/"LASTLN" = LESSER AND/OR LAST.
/"TEXTP" IS SET

XFIND,	0
	TAD CFRS	/INITIALIZE POINTERS TO FIRST LINE
	DCA LASTLN
	TAD CFRS
FINDN,	DCA THISLN	/SAVE THIS ONE
	TAD THISLN
	DCA XRT
	TAD LINENO
	CLL CMA IAC	/CLEAR LINK AND NEGATE LINENO.
	JMS I DXRT	/TAD I XRT
	SNA
	JMP FEND3-1	/FOUND IT.
	SZL CLA
	JMP FEND3	/PAST IT.
	TAD THISLN	/MOVE POINTERS
	DCA LASTLN
	JMS I DTHIS	/TAD I THISLN
	SZA
	JMP FINDN	/NOT YET
	SKP
	ISZ XFIND	/2ND EXIT = FOUND
FEND3,	TAD THISLN	/1ST RETURN = NOT FOUND
	IAC
	DCA AXOUT	/SET "TEXTP".
	DCA XCT
	JMP I XFIND	/--RETURN--


UTRA,	0		/UNPACK CHARACTER. - "GETC"
	JMS GET1
UTE,	SPA CLA		/NORM & EXTEND
	TAD C100	/300-337 & 340-376
	TAD M137	/240-276 & 200-236
	TAD CHAR
	SNA
	JMP UTX		/"?" FOUND
	TAD P337
UTQ,	DCA CHAR
	TAD DEBGSW
	TAD DMPSW
	SNA CLA		/PRINT ONLY IF BOTH ARE ZERO.
	PRINTC
	JMP I UTRA	/--RETURN--
EXTR,	JMS GET1
	CMA
	JMP UTE
UTX,	TAD DEBGSW	/TEST FOR TRACE-ENABLED
	SZA CLA
	JMP .+6
	TAD DMPSW	/FLIP THE TRACE FLOP
	SNA CLA
	IAC
	DCA DMPSW
	JMP UTRA+1	/GET NEXT CHARACTER INSTEAD.
	TAD P277	/TRACE DISABLED = RETURN "?"
	JMP UTQ
GET1,	0		/UNPACK 6-BITS
	ISZ XCT		/STARTS=0
	JMP GET3
	TAD GTEM
GEND,	AND P77
	DCA CHAR	/SAVE
	TAD CHAR
	TAD M77
	SNA CLA
	JMP EXTR	/EXTENDED
	TAD CHAR
	TAD M40
	JMP I GET1	/--RETURN--
GET3,	JMS I DAXOUT	/TAD I AXOUT
	DCA GTEM
	CMA
	DCA XCT
	TAD GTEM
	RTR CLL
	RTR
	RTR
	JMP GEND
M40,	-40
M137,	-137
XENDLN,	0	/TERMINATE THE BUFFERED LINE - "ENDLN"
	CDF
	TAD I LASTLN	/SAVE OLD POINTER
	DCA I BUFR
	TAD BUFR	/POINT TO NEW LAST LINE
	DCA I LASTLN
	TAD ADD		/CHECK FOR EXTRA INFO
	SZA 
	DCA I AXIN
	TAD AXIN	/COMPUTE NEW END OF BUFFER
	IAC
	DCA BUFR
	DCA I LIBN	/WE'VE ADDED A NEW LINE
	CDF 10		/KILL 'CURRENT PROGRAM SAVED' FLAG
	JMP I XENDLN	/--RETURN--
/---------------------------------------------------------------------



TLIST3=.	/LITERAL TERMINATORS
	TASK4	/"
	PC1	/C.R. = AUTOMATIC QUOTE MATCH


INFIX=.		/DATA CONTROL CHARACTERS
	FLINTP+2	/LEFT ARROW	= KILL
	INPUT+1		/RUBOUT 	= IGNORE
	INPUT+1		/L.F.	 	= IGNORE
	ENDFI+5		/ALT MODE 	= EXIT

	INPUT+1		/^L IN ASK STATEMENT, IGNORE IT
FLTONE,	0001	/(NO RELATIVE REFERENCES)
	2000
FLTZER,	0000
	0000
	0000
	0000
M12,	-12	/DECIMAL CONVERSION FACTOR FOR "PRNT"
/----------------------------------------------------------------------


XPUSHJ,	0
	CLA CLL IAC
	TAD XPUSHJ	/BUMP RETURN ADDRESS
	PUSHA		/SAVE IT ON THE STACK
	TAD I XPUSHJ	/GET THE ADDRESS
	DCA XPUSHJ	/INDIRECT INDIRECT!
	JMP I XPUSHJ

XPRNT,	0	/PRINT A LINE NUMBER - "PRNTLN"
	TAD LINENO
	RTL6
	AND P77
	JMS PRNT	/TWO DIGIT "PART" NUMBER
	TAD PER
	PRINTC		/PERIOD FOR SEPARATION
	TAD LINENO
	JMS PRNT	/TWO DIGIT "STEP" NUMBER.
	TAD M140
	DCA CHAR	/SAVE SPACE IN CHAR.
	PRINTC		/PRINT TRAILING SPACE
	JMP I XPRNT	/--RETURN--
VAL=T1
PRNT,	0	/PRINT TWO DECIMAL DIGITS
	AND P177
	DCA VAL
	TAD C260
	DCA T3
	JMP .+3
	ISZ T3
XYZ,	DCA VAL
	TAD VAL
	TAD M12
	SMA
	JMP XYZ-1
	CLA
	TAD T3
	PRINTC
	TAD VAL
	TAD C260
	PRINTC
	JMP I PRNT	/--RETURN--
OUT,	0		/OUTPUT A CHARACTER - "PRINTC"
	SNA		/USE (AC) OR (CHAR)
	TAD CHAR
	CIF
	JMS I TAB	/COUNT CHARACTERS
	JMP OUTCR	/IT WAS A CR, PRINT CR/LF
	JMS I OUTDEV	/PRINT NORMAL CHAR
	JMP I OUT
OUTCR,	TAD CCR
	JMS I OUTDEV
	TAD CLF
	JMS I OUTDEV
	TAD C200	/PRINT 2 NULLS
	JMS I OUTDEV	/AFTER EACH CR/LF
	TAD C200
	JMP OUTCR-2
TAB,	TABCNT

PACBUF,	0		/PACK A CHARACTER - "PACKC"
	TAD P277
	CIA
	TAD CHAR
	SNA		/CHANGE 277 TO 337
	TAD P40
	TAD M100
	SNA		/TEST FOR RUBOUT.
	JMP I RUBIT
	TAD P377
	DCA T2		/SAVE INPUT ITEM
	TAD T2		/SO THAT QUESTION DOESN'T MAKE
	AND C140	/CHAR LOOK LIKE A LEFT-ARROW
	TAD M140
	SZA		/DATA WORD.
	TAD C140
	SNA CLA
	JMP ESCA	/340-377 AND 200-237
PA1,	TAD T2		/240-337
	AND P77
	SZA	 	/IGNORE 300
	JMS PCK1
PACX,	CDF 10		/RESTORE FIELD AFTER 'PACKC'
	JMP I PACBUF	/--RETURN--
ESCA,	TAD P77
	JMS PCK1
	JMP PA1
PCK1,	0
	ISZ XCTIN	/=0 TO START
	JMP ROT
	TAD ADD
	JMS I DAXIN	/DCA I AXIN
	DCA ADD		/CLEAR PACKING WORD	/*8K*
	TAD PDLXR	/CHECK FOR OVERFLOW	/*8K*
	CMA IAC CLL			/*8K*
	TAD P13		/RESERVATIONS FOR PUSH-DOWN LIST/*8K*
	TAD AXIN
	SNL CLA
	JMP I PCK1	/--RETURN--
	ERROR2		/FULL BUFFER
P40,	40
P377,	377
C140,	140
RUBIT,	RUB1
M140,	-140
ROT,	RTL6	/(EAE)
	DCA ADD
	CMA
	DCA XCTIN
	JMP I PCK1


PS8PC,	0		/PC
	CDF
	TAD I PC
	CDF 10
	JMP I PS8PC

AXOUTD,	0
	CDF
	TAD I AXOUT
	CDF 10
	JMP I AXOUTD
/INPUT OUTPUT HANDLERS -- NO INTERRUPTS
*2600

MBREAK,	-220		/CONTROL-P
MCTRLC,	-203		/CONTROL-C

RANRAN,	ISZ RISZ	/BUMP RANDOM NUMBER
	JMP XI33+1	/WHILE WAITING FOR INPUT
	JMP RANRAN	/DON'T LEAVE ZERO

XI33,	0		/VIA (INDEV)
	KSF
	JMP RANRAN	/BUMP RANDOM NUMBER
	KRB
	AND P177	/IGNORE PARITY BIT
	SNA
	JMP XI33+1	/IGNORE NULL
	TAD C200	/FORCE PARITY BIT ON
	JMS XTSBRK
	JMP I XI33	/--RETURN--

XOUTL,	0		/VIA (OUTDEV)
	DCA XI33	/TEMP. STORAGE
	TAD XI33
	TSF
	JMP XOUBRK	/CHECK FOR BREAK CHARS.
	TLS
	CLA CLL
	JMP I XOUTL	/--RETURN--

XOUBRK,	CLA CLL
	KSF		/BREAK?
	JMP XOUTL+2	/NO
	KRB		/YES
	AND P177
	TAD C200
	JMS XTSBRK
	CLA CLL
	JMP XOUTL+2

XTSBSV,	0	/TEMPORARY STORAGE FOR XTSBRK
XTSBRK,	0	/TEST FOR BREAK CHAR
	DCA XTSBSV
	TAD XTSBSV
	TAD MCTRLC
	SNA CLA
	JMP CNTRC	/RETURN TO MONITOR
	TAD XTSBSV
	TAD MBREAK
	SNA CLA
	JMP RECOVR	/RETURN TO *
	TAD XTSBSV	/NO BREAK -- RESTORE AC
	JMP I XTSBRK

/HANDLE CTRL/C
CNTRC,	CIF CDF
	JMP I .+1
	7600

XKSF,	0	/TEST FOR KEYBOARD BREAK
	KSF
	JMP I XKSF	/NO
	KRB
	AND P177
	TAD C200
	JMS XTSBRK
	CLA CLL		/IGNORE NON-BREAK CHAR
	JMP I XKSF

/ERROR RECOVERY PROCEEDURE

ERROR5,	DCA .+1
ERR2,	0
	CLA CLL CMA	/PUT ERROR CODE IN 'LINENO' FOR 'PRNTLN'
	TAD ERR2
	SKP
RECOVR,	TAD C200	/TELETYPE BREAK
	DCA LINENO
	DCA INBUF	/AND INPUT BUFFER
	TLS		/SET TTY FLAG TO PREVENT HANGUP
	TSF
	JMP .-1
RECOVX,	CIF CDF		/DO LOWER FIELD FIXES
	JMP XRESTOR	/IN FIELD 0
RECOVY,	TAD (PRINTC	/'OPEN INPUT TTY:,ECHO; OPEN OUTPUT TTY:'
	DCA PPRNT
	TAD (XI33
	DCA INDEV
	TAD (XOUTL
	DCA OUTDEV
	TAD CCR		/PRINT CR/LF BEFORE ERROR MESSAGE
	PRINTC
	TAD P277
	PRINTC		/PRINT A '?'?
	PRNTLN
	ISZ PC
	JMS I DPC
	SNA
	JMP .+6
	DCA LINENO
	TAD P7700
	PRINTC
	PRINTC
	PRNTLN
	TAD CCR
	PRINTC
	JMP START

PAGE
/CHARACTER REMOVAL ROUTINE

RUB1,	TAD XCTIN	/RUBOUT ONE LETTER
	SZA CLA
/----------------------------------------------------------------------
	JMP .+6
	TAD AXIN
	CIA
	TAD PACKST
	SMA CLA		/TEST NULL LINE
	JMP I RUB5
	TAD SPLAT	/FOR A RUBOUT ACKNOWLEDGEMENT
	JMS I ECHOP	/SHALL WE ECHO A '\'?
	TAD AXIN
	DCA T2
	CDF		/LOWER FIELD TO RUBOUT TEXT
	ISZ XCTIN	/TEST HALF
	JMP RUB2
	TAD I T2	/"ADD" IS FULL.
	AND P77
	TAD M77
	SZA CLA		/TEST FOR EXTEND
	JMP RUB4
RUB3,	CMA		/SET SWITCH
	DCA XCTIN
	CMA		/BACKUP POINTER
	TAD AXIN
	DCA AXIN
	TAD I T2	/RESET ADD
	AND P7700
RUB4,	DCA ADD
	JMP I RUB5
RUB5,	PACX
RUB2,	TAD I T2	/CHECK FOR EXTENDED
	AND P7700
	TAD C100
	SZA CLA
	JMP RUB3
	DCA I T2	/SAVE CORRECTION
	JMP RUB3+1
SPLAT,	334


/SYMBOL TABLE TYPEOUT ROUTINE

TDUMP,	TAD END		/INIT POINTER FOR DUMP (DON'T DUMP SECRET)
	DCA PT1
	TAD LASTV	/TEST FOR END OF LIST
	CIA
	TAD PT1
	SNA CLA
	POPJ
	TAD I PT1	/GET THE VARIABLE
	CDF		/FOR PFOCAL
	DCA I OP+1
	CDF 10
	TAD OP		/SETUP UNPACK POINTERS
	DCA AXOUT
	DCA XCT
	GETC		/READ AND PRINT "XX("
	PRINTC
	GETC
	PRINTC
	GETC
	PRINTC
	ISZ PT1
	TAD I PT1	/PRINT SUBSCRIPT TO 99
	JMS I PRNT2
	GETC		/PRINT ")"
	PRINTC
	ISZ PT1
	FINT		/PICK UP VALUE
	FGET I PT1
	FXIT
	JMS I FOUTPUT	/PRINT VALUE
	TAD CCR
	PRINTC
	TAD GINC
	TAD M2
	TAD PT1
	JMP TDUMP+1

PRNT2,	PRNT
OP,	PC0+3
	PC0+4
	0
ECHO,	0
	DCA CHAR	/SAVE IN CHAR
	TAD I PPPRNT	/DO WE WANT TO PRINT?
	SNA CLA
	JMP I ECHO	/NO
	PRINTC		/YES
	JMP I ECHO
PPPRNT,	PPRNT

ICHARF,	0		/INPUT A CHARACTER FROM A FILE
	CIF CDF
	JMS I CHARI	/CALL LOWER FIELD
	JMP I ICHARF

CHARI,	ICHAR

FILER,	CIF		/FILE COMMANDS ('OPEN')
	JMP I .+1
	FILEST

X133P,	XI33

TERMER,	0		/CHECK FOR TERMINATOR (;, CR, SPACE,
	SORTC
		GLIST-1
	ISZ TERMER
	CIF CDF
	JMP I TERMER

EOF,	0		/TRYING TO READ FROM A FILE AFTER END
	TAD X133P	/(SHAME ON YOU!)
	DCA INDEV	/RESET POINTER TO TTY
	TAD P277	/PRINT A '?'
	JMS XOUTL	/ON THE TELETYPE
	JMS I INDEV	/READ A CHARACTER
	JMP I EOF


OCHAR,	0		/OUTPUT A CHARACTER
	DCA T2
OUTECH,	SKP		/ECHO ON TELETYPE?
	JMP .+5
	TAD T2		/MNO
	SNA		/YES
	CLA CLL CML RAR	/LET HIM PRINT NULLS!
	JMS I OUTLP
	TAD T2
	CIF
	JMS I NOCARE	/OUTPUT IT
	JMP I OCHAR
OUTLP,	XOUTL
NOCARE, NOCHAR

	PAGE

/-------------------------------------------------------------------




	IFNDEF FDIS <	/FDIS FOR TEKTRONIX T-4002 AVAILABLE - IF
			/PRINTX OVERLAYS OLD FDIS
PRINTX,	0
	JMS I OUTDEV
	CIF
	JMP I PRINTX
	STVAR=.>
*5774
MGETC,	0		/GETC FAKE FOR LOWER FIELD
	GETC
	CIF
	JMP I MGETC
*6160
THISD,	0
	CDF
	TAD I THISLN
	CDF 10
	JMP I THISD

PT1D,	0
	CDF
	TAD I PT1
	CDF 10
	JMP I PT1D

*6311
XRAN,	FENT		/PSEUDO-RANDOM NUMBER
	FGET RNDM	/X(1)=(2^17+3)*X(0) MOD 2^16
	FPUT EX1
	FEXT
	TAD M16
	DCA T1S
	JMS I DOUBLE
	ISZ T1S
	JMP .-2
	JMS I PADDR
	JMS I DOUBLE
	JMS I PADDR
	FINT
	FPUT RNDM
	FEXT
	DCA FLAC
	CLA CLL CMA RAR	/=3777
	AND FLAC+1
	DCA FLAC+1	/BE POSITIVE IT'S POSITIVE
	JMP I EFUN3I

M16,	-16
PADDR,	DUBLAD
	RNDM=.
T1S,	0
	4421
	3040
	0001
XRTD,	0
	CDF
	TAD I XRT
	CDF 10
	JMP I XRTD
AXIND,	0
	CDF
	DCA I AXIN
	CDF 10
	JMP I AXIND

/THIS IS THE "LIBRARY HEAD"
*7503

LIB,	SPNOR		/IGNORE SPACES
	TSF		/WAIT FOR OUTPUT TO FINISH
	JMP .-1		/(DECTAPE SYSTEMS REALLY NEED THIS!)
	CIF CDF		/CALL LOWER FIELD
	JMP I (LOWLIB

	TAD (JMP I GOSWITCH+1	/RETURN TO APPROPRIATE ROUTINE
	TAD GOSWITCH
	DCA GOSWITCH
GOSWITCH,	JMP I .+1

	PROC
	START
	LGOSUB
	GOTO+1

FIN,	READC		/SINGLE CHARACTER INPUT FUNCTION
	TAD CHAR	/FLOAT THE CHARACTER
	DCA FLAC+1
	DCA FLAC+2	/CLEAR THE REST OF FLAC
	DCA FLAC+3
	TAD P13		/AND SET THE PROPER EXPONENT
	DCA FLAC
	JMP I EFUN3I

ECHOGO,	CHIN+7
	CHIN+7

FOUT,	JMS I INTEGER		/SINGLE CHARACTER OUTPUT FUNCTION
	SNA
	TAD P4000	/IN CASE IT'S ZERO
	PRINTC
	JMP I EFUN3I

CPRNT,	0		/CROSS FIELD FAKES!
	PRINTC
	CIF CDF
	JMP I CPRNT

PGETLN,	0
	GETLN
	CIF CDF
	JMP I PGETLN

FRAN,	TAD (XRAN	/RANDOM RANDOM NUMBERS
	DCA I (PFRAN		/(FIRST CALL ONLY)
	TAD RISZ		/INITIALIZE 'RNDM'
	DCA I (RNDM+1
	JMP I (XRAN

XSGN,	TAD FLAC+1		/REAL SIGNUM FUNCTION!!
	SNA CLA
	JMP I EFUN3I
	PUSHF
		FLTONE
	POPF
		FLAC
	JMP XABS





	PAGE
/PFLOTB -- PS/8 FOCAL FLOATING POINT PACKAGE
/AS OF OCTOBER 4, 1974,  PFLOTB IS IDENTICAL WITH PFLOTA

/COPYRIGHT 1971  DIGITAL EQUIPMENT CORPORATION
/	MAYNARD, MASSACHUSETTS 01754

/
IFNDEF T <XLIST>
*4434
	JMP I .+5

*4441
	4300

/REMOVE
/SPECIAL VERSION TO REMOVE FSQT,FSGN ONLY
*4300
	DATUMA-12
	DMULT+12
	DMULT4+3

*4303
	TAD .-2
	SZA CLA
	JMP I .+2
	SKP
	PUSHA-DMPSW
	DCA THISLN+6
	DCA THISLN+12
	DCA THISLN-1
	TAD .+3
	DCA I .+3
	JMP I .-6
	PCHECK+1
	LOOP01-TERMS+5
IFNDEF T <XLIST>




/PAGE ZERO OF THE
/FLOATING POINT ARITHMETIC INTERPRETER FOR FOCAL



	FIELD 1

*40

EX1,	0	/OPERAND STORAGE
AC1H,	0
AC1L,	0
OVER1,	0

FLAC=.		/FLOATING ACCUMULATOR
EXP,	0	/F.A.
HORD,	0
LORD,	0
OVER2,	0

SIGNF,	0		/FLOATIN SIGN

MINSKI,	ACMINS		/NEGATE FLAC SUBROUTINE
FISW,	0		/OUTPUT FORMAT
INTEGER,FIX		/FIX FLAC



/FUNCTIONS CONTAINED IN THIS SECTION

	/ARTN
	/FEXP
	/FLOG
	/FSIN
	/FCOS
	/XSQRT
/FLOATING POINT PACKAGE - EXPONENTIAL

GETSGN=TAD FLAC+1
RETURN=JMP I EFUN3I

*4600+20

FEXP,	GETSGN			/TAKE ABSOLUTE VALUE
	SPA CLA
	JMS I NEGP
	DCA T3		/C(SIGN)=-1 IF I X2<0
	FINT
	FMUL LG2E
	FPUT I X2
	FEXT
	JMS I INTEGER	/TAKE INTEGER PART
	DCA FLAG2	/SAVE LOW ORDER DATA
	FINT
	FNOR
	FPUT I XSQ2
	FGET I X2
	FSUB I XSQ2
	FPUT I X2
	FMUL I X2
	FPUT I XSQ2
	FADD DF
	FPUT TEMP
	FGET CF
	FDIV TEMP
	FSUB I X2
	FADD AF
	FPUT TEMP
	FGET BF
	FMUL I XSQ2
	FADD TEMP
	FPUT TEMP
	FGET I X2
	FDIV TEMP
	FMUL TWO
	FADD ONE
	FEXT
	TAD FLAG2
	TAD FLAC
	DCA FLAC
	ISZ T3
	RETURN
	FINT
	FPUT I X2
	FGET ONE
	FDIV I X2
	FEXT
	RETURN

/CONSTANTS FOR FEXP

X2,	X
XSQ2,	XSQR
AF,	0004
	2372
	1402
BF,	7774
	2157
	5157
CF,	0012
	5454
	0343
DF,	0007
	2566
	5341
LG2E,	0001
	2705
	2435
ONE,	0001
	2000
	0000
TWO,	0002
	2000
	0000
NEGP,	FNEG

FLAG2,	0
TEMP,	0
	0
	0
	0



/MAIN ALGORITHM FOR ARCTANGENT

ARCALG,	FINT
	FGET I X2
	FMUL I X2
	FPUT I XSQ2
	FMUL BET2
	FADD BET1
	FMUL I XSQ2
	FADD BETZ
	FPUT TEMP
	FGET ALF2
	FMUL I XSQ2
	FADD ALF1
	FMUL I XSQ2
	FADD ALFZ
	FMUL I X2
	FDIV TEMP
	FEXT
	JMP I .+1
 	ARCRTN



/CONSTANTS - FLOATING ARC TANGENT
ALFZ,	0000
	2437
	1643
ALF1,	7777
	3304
	4434
ALF2,	7773
	3306
	5454
BETZ,	0000
	2437
	1646
BET1,	0000
	2427
	2323
BET2,	7775
	3427
	7052



/------------------------------------------------------------
/------------------------------------------------------------
/FLOATING POINT ARC TANGENT

*5000

ARTN,	GETSGN		/TAKE ABSOLUTE VALUE
	SPA CLA
	JMS FNEG
	DCA T3
	FINT
	FPUT I X1
	FSUB I CON1
	FEXT
	GETSGN
	SPA CLA
	JMP GO		/LESS THAN ONE
	FINT
	FGET I CON1
	FDIV I X1
	FPUT I X1
	FEXT
	CLA CMA
GO,	DCA FLAG1	/SIGN FLAG OF RESULT
	JMP I .+1	/CALL ALGORITHM
	ARCALG
ARCRTN,	ISZ FLAG1	/RETURN HERE
	JMP I EXIT1
	FINT
	FPUT I X1
	FGET I PI2
	FSUB I X1
	FEXT
	JMP I .+1
EXIT1,	EXIT2

/CONSTANTS FOR ARCTANGENT
X1,	X
PI2,	PIOT
CON1,	ONE


FLOG,	GETSGN		/FLOATING LOGARITHM
	SNA
	ERROR3		/ZERO ARGUEMENT FOR LOG
	SPA CLA
	ERROR3		/NEGATIVE ARGUMENT
	FINT
	FPUT I TEM
	FSUB I CON1
	FEXT
	GETSGN
	SNA
	RETURN
	SMA CLA
	JMP STARTL
	FINT
	FGET I CON1
	FDIV I TEM
	FPUT I TEM
	FEXT
	CLA CMA
STARTL,	DCA T3
	TAD P13
	DCA FLAC
	CMA
	TAD I TEM
	DCA FLAC+1
	DCA FLAC+2
	DCA FLAC+3
	IAC
	DCA I TEM
	FINT
	FMUL LOG2
	FPUT I X1
	FGET I TEM
	FSUB I CON1
	FPUT I TEM
	FMUL LOG8
	FADD LOG7
	FMUL I TEM
	FADD LOG6
	FMUL I TEM
	FADD LOG5
	FMUL I TEM
	FADD L4
	FMUL I TEM
	FADD L3
	FMUL I TEM
	FADD L2
	FMUL I TEM
	FADD L1
	FMUL I TEM
	FADD I X1
	FEXT
	JMP I EXIT1


L1,	0000
	3777
	7742
L2,	7777
	4000
	4100
L3,	7777
	2517
	0310
L4,	7776
	4113
	7211

/LOGARITHM CONSTANTS

LOG5,	7776
	2535
	3301
LOG6,	7775
	4746
	0771
LOG7,	7774
	2236
	4304
LOG8,	7771
	4544
	1735

TEM,	TEMP
LOG2,	0
	2613
	4414
FLAG1,	0




FNEG,	0
	JMS I MINSKI
	CLA CMA
	JMP I FNEG


/------------------------------------------------------------
/------------------------------------------------------------
/FLOATING POINT SINE AND COSINE

*5200

FCOS,	FINT		/COS(X)=SIN(PI/2-X)
	FPUT X
	FGET PIOT
	FSUB X
	FEXT
FSIN,	GETSGN
	SMA SZA CLA
	JMP MOD
	GETSGN
	SMA CLA
	RETURN		/YES SIN(0)=0
	JMS I MINSKI
	CMA		/NO:SIN(-X)=-SIN(X)
MOD,	DCA T3
	/REDUCE X MODULO 2 PI
	FINT
	FDIV TWOPI
	FPUT XSQR
	FEXT
	JMS I INTEGER
	FINT
	FNOR
	FPUT X
	FGET XSQR
	FSUB X
	FMUL TWOPI
	FPUT X
	FSUB PI		/X<PI?
	FEXT
	GETSGN
	SPA CLA
	JMP PCHECK	/YES
	FINT		/NO, SIN(X-PI)=-SIN(X)
	FPUT X
	FEXT
	TAD T3		/INVERT THE SIGN
	CMA
	DCA T3

PCHECK,	FINT		/X<PI/2?
	FGET X
	FSUB PIOT
	FEXT
	GETSGN
	SPA CLA
	JMP PALG	/YES
	FINT		/NO
	FGET PI		/SIN(X)=SIN(PI-X)
	FSUB X
	FPUT X
	FEXT

PALG,	FINT
	FGET X
	FDIV PIOT
	FPUT X
	FMUL X
	FPUT XSQR
	FGET C9
	FMUL XSQR
	FADD C7
	FMUL XSQR
	FADD C5
	FMUL XSQR
	FADD C3
	FMUL XSQR
	FADD PIOT
	FMUL X
	FEXT
EXIT2,	ISZ T3
	RETURN
	JMS I MINSKI
	RETURN

/CONSTANTS AND POINTERS



TWOPI,	0003
	3110
	3755	/(3756) - FOR 3-WORD
	2421

PI,	0002
	3110
	3755	/(3756) - FOR 3-WORD
	2421

PIOT,	0001		/USED BY SINE AND COSINE
	3110
	3755	/(3756) - FOR 3-WORD
	2421

X,	0000
	0000
	0000
	0000

XSQR,	0000
	0000
	0000
	0000

/SINE CONSTANTS

C9,	7764
	2501
	7015
	1042
C7,	7771
	5464
	5514
	6150
C5,	7775
	2431
	5361
	4736
C3,	0000
	5325
	0414
	3167

/END OF EXTENDED FUNCTIONS.



/------------------------------------------------------------
/------------------------------------------------------------
/  - INPUT/OUTPUT ROUTINES FOR THE FOCAL
/FLOATING POINT PACKAGE.


/IN THE COMMENTS BELOW:-
/ F = NUMBER OF DIGITS TO BE OUTPUT	=FISW
/ D = NUMBER OF DECIMAL PLACES		=DECP
/ E = DECIMAL EXPONENT			=BEXP
/ P = NUMBER OF PLACES REMAINING TO BE
/     PRINTED BEFORE DECIMAL POINT


*5400

DIGITS=12	/NUMBER OF DECIMAL DIGITS OUT


TGO,	0
	DCA SCOUNT	/SAVE MAX. NUMBER OF DIGITS AVAILABLE - *SET COUNTS*
	TAD FISW
	RTL6
	AND P77
	DCA T1
	TAD T1
	CIA		/NO, COMPUTE FIELD SIZES
	SNA
	TAD MD
	DCA FCOUNT
	TAD FISW	/(JMP FPRNT) - FOR NO ROUNDGIN.
	SNA		/FLOATING OUTPUT?
	JMP R6		/YES, ROUND OFF TO MAX.NO.  PLACES
	AND P77
	DCA DECP
	TAD FCOUNT
	TAD DECP
	SPA		/ F-D > 0 ?
	JMP .+5		/YES
	CLA CMA		/NO,
	TAD T1
	DCA DECP	/MAKE D = F-1
	CMA
	TAD T3		/COMPARE DECIMAL EXPONENT
	SMA		/ F-D > E?
	CLA		/NO, ROUND OFF TO .F PLACES
	TAD T1		/YES
	SPA		/ D+E < 0 ?	
	JMP FPRNT-2	/YES, NO ROUNDING NEEDED, GO TO PRINT
	TAD MD		/NO, ROUND TO D+E PLACES,
	SMA		/TO A MAXIMUM OF D PLACES
	CLA

R6,	TAD RND2	/ *ROUND UP *
	DCA T2		/SAVE NUMBER+1 OF PLACES TO ROUND TO.
	TAD I BUFST
	TAD T2		/SET UP BUFFER ADDRESS AT WHICH
	DCA PLCE	/ROUNDING OFF SHOULD START
	TAD T2
	CIA		/SET UP COUNT OF MAXIMUM NUMBER
	DCA T2		/OF CARRIES ALLOWABLE
	TAD K4		/LITTLE EXTRA ON FIRST DIGIT.
RET,	ISZ I PLCE	/ADD 1 TO DIGIT AT CURRENT POSITION
	TAD I PLCE
	TAD OM12
	SPA CLA		/CARRY REQUIRED?
	JMP FPRNT	/NO, GO TO OUTPUT
	DCA I PLCE	/YES, MAKE CURRENT DIGIT ZERO
	ISZ T2		/BEGINNING OF BUFFER REACHED?
	JMP DECR	/NO, DECREMENT BUFFER ADDRESS AND REPEAT
	ISZ I PLCE	/YES, SET MANTISSA TO 0.1
	ISZ T3		/COMPENSATE BY INCREMENTING EXPONENT
	CLA
FPRNT,	TAD FISW	/AUTO-INDEX REGISTER ALREADY SET. - *PRINT*
	SNA CLA		/ F = 0 ?
	JMP FLOUT	/YES, OUTPUT AS FLOATING NUMBER
	TAD FCOUNT
	TAD T3
	SMA SZA		/ E > F ?
	JMP FLOUT-1	/YES,CONVERT TO E FORMAT
	TAD DECP
	SMA		/ E < F-D ?
	CLA		/NO, TAKE P = E
	CIA		/YES, TAKE P = F-D
	TAD T3
	CIA
	DCA T1		/SET UP MINUS P
BACK,	TAD T3		/PRINT DD.DDD
	TAD T1
	SNA CLA		/ P = E ?
	JMP DIG		/YES, PRINT DIGIT
	TAD T1		/NO,
	IAC
	SPA CLA		/ P > 1 ?
	TAD M20	/YES, TAKE SPACE (240-260); OTHERWISE ZERO
IN,	JMS OUTA	/PRINT CHARACTER
	ISZ T1		/P CHARACTERS PRINTED?
	JMP BACK	/NO
	TAD PER		/YES,
	PRINTC		/PRINT DECIMAL POINT
	JMP BACK

DECR,	CMA		/BACKUP TO TOP OF BUFFER.
	TAD PLCE
	DCA PLCE
	JMP RET
K4,	4
MD,	-DIGITS
RND2,	DIGITS+1
OM12,	-12
BUFST,	SADR
OPUT,	OUTDG
DECP,	0		/MODIFIABLE LOCATIONS
SCOUNT,	0
FCOUNT,	0
PLCE=.
OUTA,	0		/MODIFIED REGISTERS.
	JMS I OPUT	/PRINT CHARACTER
	ISZ FCOUNT	/F CHARACTERS PRINTED?
	JMP I OUTA	/NO--RETURN--
	JMP I TGO	/YES, NUMBER FINSHED
DIG,	CMA
	TAD T3		/REDUCE E, BY 1
	DCA T3
	ISZ SCOUNT	/ARE ALL SIG. FIGS. USED?
	JMP .+4		/NO
	CMA		/YES,
	DCA SCOUNT	/RESET COUNT TO -1
	JMP IN		/AND LEAVE C(AC) = 0
	TAD I FLTXR	/TAKE NEXT DIGIT FROM BUFFER
	JMP IN
/DO FLOATING OUTPUT
	CLA		/IF OUTPUT TOO LARGE,
FLOUT,	JMS I OPUT	/PRINT "0"
	TAD PER
	PRINTC		/PRINT "."
	ISZ TGO		/SECOND RETURN
	TAD I FLTXR	/TAKE NEXT DIGIT FROM BUFFER
	JMS OUTA	/PRINT IT
	ISZ SCOUNT	/TEST FOR END OF INPUT
	JMP .-3		/AND REPEAT
	CMA
	DCA SCOUNT	/OUTPUT EXTRA ZEROS.
	JMP .-5
ABSOLV,	0
	TAD HORD
	DCA SIGNF
	TAD HORD
	SPA CLA
	JMS I MINSKI
	JMP I ABSOLV	/--RETURN--


/------------------------------------------------------------
/------------------------------------------------------------
/DOUBLE PRECISION DECIMAL-BINARY
/INPUT AND CONVERSION FOR + OR - XXX...

*5600

DECONV,	0
	DCA LORD
	DCA EXP		/ZERO THE EXPONENT AND
	DCA HORD	/INITIALIZE FLOATING AC.
	DCA OVER2
	DCA DNUMBR
	DCA SIGNF
	TAD CHAR	/ALLOW KEYBOARD SIGN CHECKS.
	TAD MPLUS
	SNA
	JMP .+6		/+SIGN; GET NEXT
	TAD M2		/CHECK - SIGN
	SZA CLA
	JMP .+4
	CMA		/INIT SIGN CHECK TO POS.
	DCA SIGNF
	JMS I XINPUT	/GET NEXT
	TAD CHAR	/A SPACE PERHAPS?
	TAD MSPACE
	SNA CLA
	JMP .-4
	JMS DECON
	JMP I DECONV	/--RETURN--


DECON,	0
	TAD CHAR	/TEST LEAD CHARACTER FOR TERMINATOR
	TAD MINE
	SNA CLA
	JMP I DECON	/E--RETURN--
	TESTN
	JMP I DECON	/.--RETURN--
	JMP DTST	/OTHER
	TAD SORTCN	/N
DSAVE,	DCA DIGIT	/YES
	JMS MULT10	/REMAIN MUST =0 SINCE OVERFLOW IS CHECKED
	ISZ DNUMBR	/COUNT DIGITS
	SZA CLA
	ERROR2		/INPUT-OVERFLOW ERROR
	JMS I XINPUT
	JMP DECON+1	/CONTINUE
DTST,	TAD CHAR	/ALLOW A-Z
	TAD MINUSA
	SPA CLA
	JMP I DECON	/--RETURN--
	TAD CHAR
	TAD MINUSZ
	SZA SMA CLA
	JMP I DECON	/USE SIX BITS OF ASCII--RETURN--
	TAD CHAR
	AND P77
	JMP DSAVE
MINE,	-305	/(7532)- FOR AMPERSAND
MINUSZ,	-332
MPLUS,	-253
MSPACE,	-240
XINPUT,	INPUT





MULT10,	0	/ROUTINE TO MULTIPLY FLAC BY TEN (10)
	TAD OVER2
	DCA OVER1
	TAD LORD	/DOUBLE PRECISION WORD
	DCA AC1L	/BY TEN (DECIMAL)
	TAD HORD	/REMAIN=REMAINDER
	DCA AC1H
	DCA REMAIN	/CLEAR OVERFLOW WORD
	JMS MULT2	/CALL SUBROUTINE TO
	JMS MULT2	/MULTIPLY BY TWO
	JMS DUBLAD	/CALL DOUBLE ADD
	JMS MULT2
	TAD DIGIT	/ADD LAST DIGIT RECEIVED
	DCA OVER1
	DCA AC1L
	DCA AC1H
	JMS DUBLAD
	TAD REMAIN	/EXIT WITH REMAINDER
	JMP I MULT10	/IN AC--RETURN--

REMAIN,	0

DIGIT,	0	/STORAGE FOR DIGIT
DNUMBR,	0	/=NUMBER OF DIGITS
MULT2,	0	/MULTIPLY  OVER2, LORD, HORD BY 2
	TAD OVER2
	CLL RAL		/CARRY INSERT BIT IS IN LINK
	DCA OVER2
	TAD LORD
	RAL
	DCA LORD
	TAD HORD
	RAL
	DCA HORD
	TAD REMAIN
	RAL
	DCA REMAIN
	JMP I MULT2	/--RETURN--






DUBLAD,	0	/TRIPLE PRECISION ADDITION
	CLA CLL
	TAD OVER2
	TAD OVER1
	DCA OVER2
	RAL
	TAD LORD
	TAD AC1L
	DCA LORD
	RAL
	TAD HORD
	TAD AC1H
	DCA HORD
	RAL
	TAD REMAIN	/WITH OVERFLOW
	DCA REMAIN
	JMP I DUBLAD	/--RETURN--

DIV1,	0	/SHIFT OPERAND RIGHT
	CLA CLL		/TRIPLE PRECISION
	TAD AC1H
	SPA
	CLL CML
	RAR
	DCA AC1H
	TAD AC1L
	RAR
	DCA AC1L
	TAD OVER1
	RAR
	DCA OVER1
	ISZ EX1
	JMP I DIV1	/--RETURN--
	JMP I DIV1	/--RETURN--


/------------------------------------------------------------
/------------------------------------------------------------
*6000

/FLOATING OUTPUT CONVERSION ROUTINE

FLOUTP,	0
	TAD PEQ
	PRINTC		/(CLA)_ TO SUPPRESS "="
	TAD HORD	/NUMBER>0??
	SMA CLA
	TAD SMSP	/PRINT "-" OR A SPACE.
	TAD SMIN
	PRINTC
	JMS I ABSOL2
FGO2,	DCA T3		/INITIALIZE DECIMAL EXPONENT
	TAD EXP		/IS EXP 0 TO 4?
	SPA
	JMP FGO3	/TOO LARGE:MULTIPLY BY 1/10
	SZA
	TAD M4
	SPA SNA CLA
	JMP FGO4
	FINT
	FMUL I PPTEN
	FEXT
	IAC
	TAD T3
	JMP FGO2
FGO3,	FINT
	FMUL I TENPT
	FEXT
	CMA
	JMP .-6

FGO4,	DCA I DPT	/MULTIPLY BY TWO TO POSITION BIT0
	DCA I REPT	/CLEAR OVERFLOW WORD
	TAD SADR	/INIT BUFFER POINTER
	DCA FLTXR
	TAD EXP		/COMPUTE BITS IN 1ST DIGIT
	CMA CLL
	DCA OUTDG	/TEMP COUNT
	TAD DCOUNT	/SETUP COUNT OF TOTAL OUTPUT
	DCA EXP
	JMS I DOUBLE	/ROTATE OUT THE 1ST 4 BITS
	ISZ OUTDG
	JMP .-2
	TAD I REPT	/TEST FOR 10-15,0,1-9
	SNA 
	JMP FGO5	/IGNORE 1ST ZERO
	TAD FM12
	SPA CLA
	JMP .+7		/0-9
	IAC
	DCA I FLTXR	/OUTPUT A 1
	ISZ EXP		/COUNT THE DIGIT
	TAD FM12	/CORRECT REMAINDER
	ISZ T3		/BUMP DECIMAL EXPONENT
	NOP
	TAD I REPT	/COMPUTE RESULTANT OR SECOND DIGIT 
	ISZ T3
	NOP
	SKP
FGO5,	JMS I M10PT	/IE. .672X10=6+.72.. ETC
	DCA I FLTXR
	ISZ EXP		/ALL DIGITS OUTPUT??
	JMP .-3		/NO: CONTINUE
	TAD SADR	/INIT BUFFER POINTER
	DCA FLTXR
	TAD DCOUNT
	JMS I ROUND	/OUTPUT MANTISSA
	JMP I FLOUTP	/FIXED POINT DONE--RETURN--
	TAD CHRT	/PRINT "E"
	PRINTC

/OUTPUT THE EXPONENT

	TAD T3		/TAKE ABSOLUTE VALUE OF EXPONENT
	SPA
	CIA
	DCA HORD		/SAVE + POWER 
	TAD T3		/PRINT SIGN
	SMA CLA
	TAD M2
	TAD SMIN
	PRINTC
	TAD HORD
	ISZ EXP
	TAD M144
	SMA
	JMP .-3
	TAD C144
	DCA HORD		/SAVE TENS AND UNITS
	CMA		/OUTPUT HUNDREDS
	TAD EXP
	SZA		/UNLESS ZERO
	JMS OUTDG
	TAD HORD	/PRINT TWO DIGITS
	JMS I PRNTI
	JMP I FLOUTP	/--RETURN--
PRNTI,	PRNT
CHRT,	305	/E  (0246) - FOR AMPERSAND
SMSP,	240-255	/
PEQ,	240		/CHANGED FROM "=" TO SPACE
SMIN,	255
M144,	-144	/-100
C144,	0144	/+100
M4,	-4
FM12,	-12
DCOUNT,	-DIGITS-1	/NUMBER OF DIGITS OUTPUT
PPTEN,	PTEN	/IEI
DPT,	DIGIT
REPT,	REMAIN	/OVERFLOW FROM INTEGER MULTIPLY
M10PT,	MULT10
SADR,	BUFFER-1
ROUND,	TGO	/ACTUAL OUTPUT ROUTINE
TENPT,	TEN
ABSOL2,	ABSOLV
OUTDG,	0		/OUTPUT ONE DIGIT
	TAD C260
	PRINTC
	JMP I OUTDG	/--RETURN--

/USED BY 8K



/------------------------------------------------------------
/------------------------------------------------------------
/FLOATING POINT INPUT

*6200

FLINTP,	0		/IF C(AC) = 0, USE CHAR
	SZA CLA		/IF C(AC) NON-ZERO , GET NEXT
	JMS I XIN	/GET FIRST CHAR
	TAD CHAR	/IGNORE LEADING SPACES
	TAD M240
	SNA CLA
	JMP .-4
	JMS I DPCVPT	/READ FIRST DIGIT GROUP	
	TAD CHAR	/AND SET "SIGNF"
	TAD MPER
	SZA CLA		/ENDED BY PERIOD?
	JMP FIGO1
	JMS I XIN	/YES, READ 2AND GROUP
	DCA I DPN
	JMS I DCONP
	TAD I DPN	/SAVE NUMBER OF DIGITS IN T3
	CMA IAC
FIGO1,	DCA T3		/NO,
	TAD P43
	DCA EXP
	JMS I RESOL5
	JMS I INORM	/NORMALIZE FIRST, THEN
	FINT
	FPUT I PT1	/SAVE NUMBER
	FEXT
	TAD CHAR
	TAD MINUSE
	SZA CLA		/"E" READ IN?
	JMP ENDFI+3	/NO
	JMS I XIN	/YES, READ 3RD DIGIT GROUP
	JMS I DPCVPT	/I.E. CONVERT DECIMAL EXPONENT
	JMS I RESOL5
	TAD OVER2
	TAD T3		/C(SEXP)PLACES TO RIGHT
	DCA T3		/OF LAST DIGIT




/COMPENSATE FOR DECIMAL EXPONENTS

ENDFI,	FINT		/RESTORE MANTISSA
	FGET I PT1
	FEXT
	TAD T3		/TEST DECIMAL EXPONENT
	SNA
	JMP I FLINTP	/FINISHED--RETURN--
	SMA CLA
	JMP FIGO4
	FINT		/. IS TO THE LEFT:
	FMUL PTEN	/TIMES .1000
	FPUT I PT1
	FEXT
	IAC
	JMP .+6
FIGO4,	FINT		/. IS TO THE RIGHT:
	FMUL TEN	/MULTIPLY BY 10
	FPUT I PT1
	FEXT
	CMA
	TAD T3
	DCA T3
	JMP ENDFI+3
TEN,	0004
	2400
	0000
	0000

PTEN,	7775
	3146
	3146	/(3147) - FOR 3-WORD
	3150

MINUSE,	-305	/(7532) - FOR AMPERSAND

DPCVPT,	DECONV
DCONP,	DECON
RESOL5,	RESOLV
DPN,	DNUMBR
XIN,	INPUT
INORM,	DNORM
P43,	43

/END OF FLOATING POINT INPUT

/7 FREE

/USED BY H.S. READER

/------------------------------------------------------------
/------------------------------------------------------------
*6400
	/ FLOATING-POINT INTERPRETER FOR FOCAL.

FPNT,	0
	CLA CLL
	NOP		/(DCA OVER2) - FOR 3-WORD
	NOP		/(DCA OVER1) - FOR 3-WORD.
	TAD I FPNT	/GET NEXT INSTRUCTION
	SNA
	JMP I FPNT	/FAST EXIT--RETURN--
	DCA JUMP
	TAD JUMP
	AND C200	/GET PAGE BIT
	SNA CLA		/PAGE ZERO?
	JMP .+3		/YES
	TAD P7600	/NO
	AND FPNT	/C(FPNT)0-4 CONTAINS PAGE BITS
	DCA ADDR
	TAD P177	/GET 7 BIT ADDRESS
	AND JUMP
	TAD ADDR
	DCA ADDR
	TAD INDRCT	/INDIRECT BIT=1?
	AND JUMP
	SNA CLA
	JMP LOOP01	/NO-GO ON
	TAD I ADDR	/YES ,DEFER ,W/O AUTO-INDEX
	DCA ADDR
LOOP01,	ISZ FPNT
	CMA
	TAD ADDR
	DCA FLTXR2
	TAD JUMP	/GET COMMAND
	CLL RTL
	RTL
	AND P17		/GET BITS 0-2,IE OPCODE
	SNA
	JMP FLGT
	TAD TABLE	/LOOKUP IN TABLE
	DCA JUMP
	TAD I JUMP
	SNA
	JMP FLPT
	DCA JUMP
	TAD CEX1	/SAVE FLOATING ARGUEMENT,UNLESS'GET' OR 'PUT'
	DCA FLTXR
	TAD MFLT
	DCA CNTR
	TAD I FLTXR2
	DCA I FLTXR
	ISZ CNTR
	JMP .-3
	JMP I JUMP	/GO THERE


JUMP,	0

ADDR=EX1

INDRCT,	0400
TABLE,	ITABLE
FLPT,	TAD CEXP	/EXP TO (ADDR)
	JMP .+5
FLGT,	TAD CEXP	/(ADDR) TO EXP
	DCA FLTXR2
	CMA
	TAD ADDR
	DCA FLTXR	/SAVE 'FROM' ADDRESS
	TAD MFLT	/3 OR 4 WORDS
	DCA CNTR
	TAD I FLTXR
	DCA I FLTXR2
	ISZ CNTR
	JMP .-3
	JMP FPNT+1
CEXP,	EXP-1
CEX1,	EX1-1


FLSU,	JMS I OPMINS	/FSUB=2 - NEGATE THE OPERAND
FLAD,	JMS I ALGN	/FLAD=1 - FIRST ALIGN EXPONENTS
	JMP FPNT+1	/RETURN IF NO ALIGNMENT IS POSSIBLE
	JMS I RAR2	/TRIPLE PRECISION ADDDITION
	JMS I RAR1	/SINCE BITS ARE SHIFTED
	JMS I TRAD	/RIGHT
NORF,	JMS I NORM	/NORMALIZE THE RESULT
	JMP FPNT+1	/HINT:USE 700X FOR FUNCTIONS.

/INTERPRETIVE POWER

	NOP	/3 FREE LOCATIONS ************
	NOP
	NOP
ZERO,	DCA EXP		/YES
	DCA HORD
	DCA LORD
	DCA OVER2
	JMP FPNT+1
FLEX,	PUSHF		/AC TO A + POWER
	FLAC
	PUSHF		/SETUP ARGUMENT ( THE EXPONENT)
	EX1
	POPF
	FLAC
	JMS I INTEGER	/ONLY POSITIVE, INTEGER  EXPONENTS
	SPA
	JMP .+5		/(COULD DIVIDE)
	CMA
	DCA JUMP	/TEMP STORAGE
	NOP		/(DCA OVER1) - FOR 3-WORD
	TAD HORD
	SZA CLA
	ERROR2		/TOO LARGE OR NEGATIVE EXPONENT
	PUSHF		/INITIALIZE TO ONE.
	FLTONE
	POPF
	FLAC
	POPF
	ITER1
	JMP .+6
	PUSHF
	ITER1
	POPF
	EX1
	JMS I MULT	/"MULT"
	ISZ JUMP
	JMP .-6
	JMP FPNT+1
FLMY,	JMS I MULT	/MULTIPLY
	JMP FPNT+1
/------------------------------------------------------------


OPMINS,	MINUS2
MULT,	DMULT
NORM,	DNORM
ALGN,	ALIGN
RAR1,	DIV1
RAR2,	DIV2
TRAD,	DUBLAD

ITABLE=.-1
	FLAD
	FLSU
	FLDV
	FLMY
	FLEX
	0000
	NORF
/------------------------------------------------------------

ACMINS,	0	/ROUTINE TO  COMPLEMENT FLAC - VIA "MINSKI"
	CLL CLA		
	TAD OVER2	/TRIPLE PRECISION NEGATION
	CMA IAC		/OF FLOATING AC
	DCA OVER2
	TAD LORD
	CMA
	SZL
	IAC CLL
	DCA LORD
	TAD HORD
	CMA
	SZL
	IAC CLL
	DCA HORD
	JMP I ACMINS	/--RETURN--


ALIGN,	0	/SUBROUTINE TO ALIGN
	TAD HORD	/BINARY POINTS
	SNA
	TAD LORD	/IS MANTISSA ZERO?
	SNA CLA
	JMP NOX1	/YES, RESULT=OPERAND
	TAD AC1H	/NO,IS OPERAND ZERO?
	SNA
	TAD AC1L
	SNA
	TAD OVER1
	SNA CLA
	JMP I ALIGN	/YES--RETURN--
	TAD EX1
	CMA IAC
	TAD EXP
	SNA		/ARE EXPONENTS EQUAL?
	JMP ADONE	/YES
	DCA ACMINS
	TAD ACMINS
	SMA		/NO
	CIA		/NEGATE AND
	DCA AMOUNT	/SAVE THE DIFFERENCE
	TAD AMOUNT
	TAD TEST2
	SPA CLA		/CAN THE EXPONENTS BE ALIGNED?
	JMP NOX		/NO, USE LARGER OF THE TWO.
	TAD ACMINS	/YES, SHIFT THE SMALLER
	SMA CLA
	JMP ASHFT
	JMS DIV2
	ISZ AMOUNT
	JMP .-2
	JMP ADONE
ASHFT,	CMA	
	TAD EX1
	DCA EX1
	JMS I TAG1
	ISZ AMOUNT
	JMP .-2
ADONE,	ISZ ALIGN
	JMP I ALIGN	/--RETURN--
NOX,	TAD EX1		/MISSION IMPOSSIBLE!
	SMA CLA		/CHECK FOR SIGN DIFFERENCE
	JMP NOX2
	TAD EXP
	SMA CLA
	JMP I ALIGN	/-+--RETURN--
	JMP .+3		/--
NOX2,	TAD EXP
	SMA CLA
	TAD ACMINS	/TEMP STORAGE OF DIFFERENCE. BOTH POS EXP OR BOTH NEG.
	SMA SZA CLA
	JMP I ALIGN	/OK (+-)--RETURN--
NOX1,	TAD EX1		/USE LARGER
	DCA EXP
	TAD AC1H
	DCA HORD
	TAD AC1L
	DCA LORD
	TAD OVER1
	DCA OVER2
	JMP I ALIGN	/--RETURN--
AMOUNT,	0
TAG1,	DIV1
/LEAVE 12 BIT ANSWER IN AC UPON RETURN
/LEAVE FLAC AS AN INTEGER,

FIX,	0		/VIA (INTEGER)
	JMS I ABSOL
	TAD EXP		/TEST FOR FRACTION
	SPA SNA CLA
	JMP FIXM	/DOUBLE CHECK FOR MINUS ONE.
	IAC
	DCA OVER1
	TAD P27		/INIT ALIGNMENT
	DCA EX1
	JMS ALIGN	/DO THE ALIGNMENT TO AN INTEGER
TEST2,	0043		/ALREADY DONE; (27)-FOR 3-WORD
	ISZ OVER2
	JMP .+4
	ISZ LORD
	SKP
	ISZ HORD
	DCA OVER2	/CLEAR THE FRACTION
	JMS I RESOL
	TAD LORD	/EXIT WITH LOW ORDER RESULT IN AC.
	JMP I FIX	/--RETURN--
P27,	27
ABSOL,	ABSOLV
RESOL,	RESOLV
FIXM,	DCA EXP		/CLEAR EXPONENT
	DCA HORD
	DCA LORD
	JMP TEST2+6
DIV2,	0	/SHIFT FLAC RIGHT
	CLA CLL
	TAD HORD
	SPA
	CML
	RAR
	DCA HORD
	TAD LORD
	RAR
	DCA LORD
	TAD OVER2
	RAR
	DCA OVER2
	ISZ EXP
	JMP I DIV2	/--RETURN--
	JMP I DIV2	/--RETURN--
/------------------------------------------------------------
SPECIAL=.	/INPUT CHARACTERS
	337	/LEFT ARROW
	377	/RUBOUT
	212	/L.F.
	375	/ALT MODE
	214		/^L IS IGNORED IN AN "ASK" COMMAND

/(A+B+C)*(D+E+F)=A*D,A*E,B*D,B*E

DMULT,	0	/N- PRECISION MULTIPLY WITH
	IAC	/PRODUCT IN TRIPLE PRECISION
	TAD EX1	/ADD EXPONENTS+1
	JMS SIGN	/AND DETERMINE SIGN OF RESULT
	SPA CLA
	JMS MINUS2
	DCA DATUM-1	/INITIALIZE RESULT
	DCA DATUM-2
	DCA DATUM-3
	DCA DATUM-4
	TAD A		/A*D
	SAVE		/STORE IN MP2
	TAD D		/SINGLE PRECISION MULTIPLY
	MULTY
	2		/ACCUMULATE STARTING IN #2 DATA WORD
	TAD E		/A*E
	MULTY
	3
	TAD B		/B*D
	SAVE
	TAD D
	MULTY
	3
	TAD E		/B*E
	MULTY
	4
DMULT4,	DCA DATUM-5	/(JMP DMDONE)-FOR 3-WORD
	DCA DATUM-6
	TAD F		/A*F
	SAVE
	TAD A
	MULTY
	4
	TAD B		/B*F
	MULTY
	5
	TAD C		/C*D
	SAVE
	TAD D
	MULTY
	4
	TAD E		/C*E
	MULTY
	5
	TAD F		/C*F
	MULTY
	6

DMDONE,	TAD DATUM-1	/COPY RESULT
	DCA HORD
	TAD DATUM-2
	DCA LORD
	TAD DATUM-3
	DCA OVER2
	JMS MULDIV
	NOP		/(DCA OVER2) - FOR 3-WORD
	JMP I DMULT	/--RETURN--

DATUM=.+6	/INTERMEDIATE STORAGE

/#6-LOW ORDER RESULT
/#5
/#4
/#3
/#2
/#1-HIGH ORDER RESULT

*DATUM-1

MULDIV,	0	/TERMINATE MULTIPLY AND DIVIDE.
	ISZ SIGNF		/CORRECT FOR SIGN
	JMS I MINSKI
	JMS I NORMF	/SHIFT LEFT
	NOP
	JMP I MULDIV	/--RETURN--
FLDV,	TAD AC1H	/4:DIVIDE
	SNA CLA
	ERROR2		/DIVISION BY ZERO
	TAD EX1		/SUBTRACT EXPONENTS+1
	CMA IAC
	IAC
	JMS SIGN	/SET UP SIGNS
	SMA CLA
	JMS MINUS2	/NEGATE DIVISOR
	JMS I DIVIDE	/DIVIDE
	JMS MULDIV
	JMP I .+1
	FPNT+1

/THIS SUBROUTINE PREPARES MULTIPLY AND DIVIDE
/FOR ANY COMBINATION OF SIGNED ARGUMENTS AND FOR ZERO.
/THE RESULT OF EITHER IS ZERO IF FLAC = 0.
/RESULT OF MULTIPLY IS ZERO IF EITHER IS ZERO;
/DIVISION BY ZERO IS CHECKED BEFORE THIS 
/ROUTINE IS CALLED. 

/THE CALLING AC CONTAINS AN UPDATE VALUE FOR THE
/EXPONENT. THE RETURNING AC CONTAINS THE SIGN OF 
/THE ARGUMENT FOR FURTHER TESTING BY EACH ROUTINE.


SIGN,	0		/TEST AND SAVE SIGN OF RESULT
	TAD EXP	/COMPUTE NEW EXPONENT FOR MUL-DIV.
	DCA EXP
	TAD P4000	/LOAD 4000 TO XOR THE SIGN BITS
	AND HORD
	TAD AC1H
	SMA CLA		/RESULT MAY BE ZERO
	CMA
	DCA SIGNF
	TAD HORD
	SNA
	JMP I REVIT	/ANSWER IS ZERO.
	SPA CLA		/TAKE ABSOLUTE VALUE OF FLAC
	JMS I MINSKI
	TAD AC1H
	SNA		/RESULT OF EITHER MAY BE ZERO
	JMP I REVIT
	JMP I SIGN	/--RETURN--

/SIGN OF RESULT = SIGNF
/+=-1
/-=0

REVIT,	ZERO
NORMF,	DNORM
DIVIDE,	DUBDIV

SAVE=DCA I .
	MP2
MULTY=JMS I .
	MP4

A=FLAC+1
B=FLAC+2
C=FLAC+3
D=AC1H
E=AC1L
F=OVER1


MINUS2,	0	/NEGATE OPERAND
	CLA CLL		/TRIPLE PRECISION
	TAD OVER1
	CMA IAC
	DCA OVER1
	TAD AC1L
	CMA
	SZL
	IAC CLL
	DCA AC1L
	TAD AC1H
	CMA
	SZL
	IAC CLL
	DCA AC1H
	JMP I MINUS2	/--RETURN--

RESOLV,	0
	TAD  SIGNF
	SPA CLA
	JMS I MINSKI
	JMP I RESOLV	/--RETURN--
/------------------------------------------------------------
/------------------------------------------------------------
*7200

MP4,	0	/SINGLE PRECISION, UNSIGNED MULTIPLY - "MULTY"
	SNA	/NO RESULT ADDED IF ZERO
	JMP I MP4	/--RETURN--

/FOR EAE INSERT THE FOLLOWING:

/7203  3206  DCA .+3
/7204  1256  TAD MP2
/7205  7425  MQL MUY
/7206  0000  0
/7207  3253  DCA MP5
/7210  7501  MQA
/7211  3255  DCA MP3
/7212  5227  JMP .+15


	DCA MP1		/12 BITS BY 12 BITS
	DCA MP5
	TAD THIR
	DCA MP3
	CLL
MP6,	TAD MP1
	RAR
	DCA MP1
	TAD MP5
	SNL
	JMP .+3
	CLL
	TAD MP2
	RAR
	DCA MP5	/SAVE HIGH ORDER RESULT
	ISZ MP3
	JMP MP6
	TAD MP1	/CORRECT LOW ORDER RESULT
	RAR
	DCA MP3
	TAD I MP4	/PICKUP SCALE FACTOR
	CIA
	TAD DATUMA	/COMPUTE ADDRESS
	DCA MP1		/TEMP
	TAD MP3		/LOW ORDER PART
	CLL
	TAD I MP1	/ACCUMULATE
	DCA I MP1
	ISZ MP1
	RAL
	TAD MP5
	TAD I MP1
	DCA I MP1
	SNL
	JMP I MP4	/NO CARRY--RETURN--
	ISZ MP1
	ISZ I MP1
	JMP I MP4	/--RETURN
	JMP .-3		/CARRY AGAIN
DATUMA,	DATUM
MP5,	0		/PRODUCT
MP1,	0		/MULTIPLIER
MP3,	0
MP2,	0		/MULTIPLICAND
THIR,	-14	/12 BITS


MIF,	-43		/(-27) - FOR 3-WORD(=7751)

DUBDIV,	0	/2 OR 3  PRECISION DIVIDE
	DCA MP4
	DCA MP1
	TAD MIF		/INIT BIT COUNTER
	DCA MP3
	SKP
DV3,	JMS I DOUBLE	/SHIFT FLAC LEFT
	CLL
	TAD OVER1
	TAD OVER2
	DCA MP5
	RAL
	TAD AC1L	/COMBINE ONE POSITION AND (4-WORD)
	TAD LORD
	DCA MP2		/SAVE RESULT
	RAL
	TAD HORD	/ADD OVERFLOW
	TAD AC1H
	SNL		/SKIP IF OVERFLOW
	JMP .+6
	DCA HORD	/UPDATE FLAC
	TAD MP5
	DCA OVER2
	TAD MP2
	DCA LORD
	CLA		/CLEAR ACCUMULATOR
	TAD MP1		/SAVE OVERFLOW BITS CIRCULARLY
	RAL
	DCA MP1	
	TAD MP4
	RAL
	DCA MP4
	TAD DNORM
	RAL		/EXTRA FOR 4-WORD
	DCA DNORM
	ISZ MP3		/TEST FOR END OF DIVIDE
	JMP DV3
	TAD DNORM
	DCA HORD
	TAD MP4
	DCA LORD
	TAD MP1
	DCA OVER2
	JMP I DUBDIV	/--RETURN--



DNORM,	0	/SUBROUTINE TO NORMALIZE FLAC
	JMS I ABSOL3
	JMS TEST4
	TAD HORD
	SNA		/IS MANTISSA=0?
	TAD OVER2
	SNA
	TAD LORD
	SNA CLA
	JMP EXIT3	/YES
	TAD HORD
	RAL CLL
	SPA CLA		/WILL SHIFT BE TOO FAR?
	JMP .+6
	JMS I DOUBLE
	CMA CLL
	TAD EXP
	DCA EXP
	JMP .-10
	JMS I RESOL3
	JMS TEST4	/DON'T LEAVE 4000
	JMP I DNORM	/--RETURN--
EXIT3,	DCA EXP		/SET TO ZERO
	JMP I DNORM	/--RETURN--
XRAR2,	DIV2
TEST4,	0
	TAD HORD	/TEST FOR 4000
	SPA
	CIA
	SPA CLA
	JMS I XRAR2	/SHIFT BACK
	JMP I TEST4	/--RETURN--

ABSOL3,	ABSOLV
RESOL3,	RESOLV

/------------------------------------------------------------
/------------------------------------------------------------
*7400


/PAGE 18

	/FLOATING SQUARE ROOT FUNCTION

XSQRT,	FINT
	FPUT FPAC1	/VALUE
	FEXT		/NEWTON'S METHOD IS USED
	GETSGN
	SPA CLA
	ERROR2		/NUMBER IS NEGATIVE=IMAGINARY ROOTS
	TAD EXP		/LINK IS =0 FROM FINT
	SPA		/MATCH THE SIGN WITH LINK BIT
	CML
	RAR
	DCA ITER1	/MAKE FIRST APPROXIMATION
	SZL		/TEST LSB OF EXP
	ISZ ITER1
	NOP
	TAD SQCON1
	DCA ITER1+1
	DCA ITER1+2
	DCA ITER1+3
	TAD FPAC1+1
	SNA
	TAD FPAC1+2
	SNA CLA
	JMP SQEND	/NUMBER=0
CLCU,	FINT
	FGET FPAC1
	FDIV ITER1
	FADD ITER1
	FEXT




	CLA CMA
	TAD EXP
	DCA EXP
	TAD EXP
	CMA IAC
	TAD ITER1
	SZA CLA		/ARE EXPONENTS EQUAL?
	JMP ROOTGO	/NO
	TAD HORD	/ARE HIGH-ORDER MANTISSAS EQUAL?
	CMA IAC
	TAD ITER1+1
	SZA CLA
	JMP ROOTGO	/NO
	TAD LORD
	CMA IAC	
	TAD ITER1+2	/DO LOW-ORDER MANTISSAS AGREE
	SMA
	CMA IAC		/WITHIN ONE BIT?
	IAC
	SMA CLA
	RETURN
ROOTGO,	FINT
	FPUT ITER1
	FEXT
	JMP CLCU
SQEND,	DCA EXP
	RETURN
SQCON1,	3015

BUFFER=.

ITER1,	0
	0
	0
	0

FPAC1,	0
	0
	0
	BUFFER+13	/ADDRESS OF NEXT FREE LOCATION IN 10-DIGIT VERSION.




/PFOCNB -- INITIALIZATION FOR PS/8 FOCAL

	*176
	INIT

	*4000
INIT,	TAD (RECOVR+1
	DCA 176
	CDF
	TAD I (207	/MOVE LENGTH OF INITIAL DIALOGUE
	CDF 10
	DCA BUFR	/(JUST IN CASE)
	TFL		/MAKE FLAG SET
	PUSHJ
		DO+1
	TAD (4300	/"#@" FOR SYSTEM STATUS
	JMS LOOKUP
	CLA CLL CMA
	TAD PT1
	DCA PT1
	FINT		/GET SYSTEM STATUS VARIABLE
	FGET I PT1
	FPUT INITMP	/SAVE IT FOR LATER
	FEXT
	TAD FLAC+1	/IF IT'S ZERO, INITIAL DIALOGUE WASN'T THERE
	SNA CLA
	JMP SECRET	/ASSUME STANDARD FEATURES
CHKLOG,	TAD (100	/"A@" (KEEP SIN & COS)
	JMS LOOKUP
	SZA CLA
	JMP CHKSIN
	JMS CHANGE	/KILL ALL EXTENDED FUNCTIONS
		SINADD-1
	TAD (TTAB-1	/SET VARIABLE BOTTOM
	JMP CHKFIL-1
CHKSIN,	TAD (200	/"B@" (KEEP ALL FUNCTIONS)
	JMS LOOKUP
	SZA CLA
	JMP CHKFIL
	JMS CHANGE	/KILL LOG, EXP, ATN
		LOGADD-1
	TAD (5177	/AND RESET BOTTOM
	DCA BOTTOM
CHKFIL,	TAD (400	/"D@" (FILE COMMANDS)
	JMS LOOKUP
	SZA CLA
	JMP CHKSP
	JMS CHANGE	/KILL FILE COMMANDS
		FILADD-1
CHKSP,	TAD (500	/"E@" (LEADING SPACE IN TYPE [FOR FILES])
	JMS LOOKUP
	SZA CLA
	JMP CHKEQ
	JMS CHANGE
		SPADD-1
CHKEQ,	TAD (700	/"G@" ('=' IN TYPE)
	JMS LOOKUP
	SNA CLA		/REVERSE SENSE ON NON-STANDARD FEATURES
	JMP CHKCOL
	JMS CHANGE
		EQADD-1
CHKCOL,	TAD (1000	/"H@" (FOR ':' IN ASK)
	JMS LOOKUP
	SNA CLA
	JMP CHKAMP
	JMS CHANGE
		COLADD-1
CHKAMP,	TAD (1100	/"I@" (FOR & INSTEAD OF E)
	JMS LOOKUP
	SNA CLA
	JMP CHKPRC
	JMS CHANGE
		AMPADD-1
CHKPRC,	TAD (300	/"C@" (EXTENDED PRECISION)
	JMS LOOKUP
	SZA CLA
	JMP SECRET
	JMS CHANGE
		FORADD-1
	TAD (-31
	DCA LOOKUP
	TAD (7270
	DCA 10
	TAD (FORFIN-1
	DCA 11
	TAD I 11
	DCA I 10
	ISZ LOOKUP
	JMP .-3
SECRET,	TAD END
	DCA LASTV	/ERASE VARIABLES
	TAD (4100
	JMS LOOKUP	/CREATE THE THREE SECRET VARIABLES
	TAD (4200
	JMS LOOKUP
	TAD (4300
	JMS LOOKUP
	CLA CLL CMA
	TAD PT1
	DCA PT1		/BACKUP PT1
	FINT		/RESTORE SYSTEM SECRET VARIABLE
	FGET INITMP
	FPUT I PT1
	FEXT
	TAD LASTV
	DCA END		/MAKE THEM SECRET
	JMP I .+1
	ERT		/ERASE ALL TEXT

INITMP,	ZBLOCK 4	/HOLDING AREA FOR '#'

	PAGE
LOOKUP,	0
	DCA EFOP
	PUSHJ
		GS1
	ISZ PT1
	TAD I PT1	/PICK UP FIRST SIGNIFICANT WORD
	JMP I LOOKUP

CHANGE,	0
	TAD I CHANGE
	ISZ CHANGE
	DCA 10
CLOOP,	TAD I 10
	SNA
	JMP I CHANGE
	DCA T2
	TAD I 10
	DCA I T2
	JMP CLOOP

/THESE ARE THE LISTS TO PATCH FOCAL TO YOUR CUSTOMIZED SPECS

/CHANGES FOR 6-DIGIT PRECISION
FORADD,	70
	5
	117
	7775
	5526
	7772
	5527
	7
	VARPCH
	NOP
	6143
	7771
	6277
	3147
	6402
	3047
	6540
	3043
	6736
	27
	7036
	5263
	7105
	2047
	7072
	3047
	7260
	7751
	0

/ADDITIONAL CHANGES FOR 6-DIGIT PRECISION -- NOT MADE WITH "CHANGE"
FORFIN,	1042
	1046
	3256
	7004
	1045
	1041
	7420
	5304
	3045
	1256
	3046
	7200
	1254
	7004
	3254
	1200
	7004
	3200
	2255
	5267
	1254
	3046
	1200
	3045
	5661

FILADD,	PUSHB		/PATCH PUSHB
	MPUSHA-1+13
	PUSHB1		/PATCH PUSHB1
	5576+13
	1201		/PATCH COMGO
	ERROR5
	0

SINADD,	405
	ERROR5
	406
	ERROR5
LOGADD,	402
	ERROR5
	403
	ERROR5
	404
	ERROR5
	0

COLADD,	1216
	1371		/'TAD ALIST'
	1217
	JMS I ECHOP
	0

SPADD,	6001
	CLA CLL		/DON'T PRINT LEADING SPACE
	6002
	CLA CLL
	0

EQADD,	6001
	1335		/'TAD PEQ'
	6002
	PRINTC
	6135
	0275		/PRINT LEADING '='
	0

AMPADD,	5662
	7532
	6133
	246
	6301
	7532
	0

	PAGE

$$$$$$$$$$$