.TITLE F.I.G.
;debug=1 ;comment this out when done messing with it
;jlc=1 ;define for (hopefully) improved code
; ****************************************************************
;
; PDP-11 FORTH              INTRODUCTION              PDP-11 FORTH
;
; ****************************************************************
;
;
;
;  PDP-11 FORTH      RT-11, RSX-11M, AND STAND-ALONE      JANUARY 1980
;
;
;
;	DEVELOPED BY THE
;		FORTH INTEREST GROUP / FORTH IMPLEMENTATION TEAM
;		P.O. BOX 1105
;		SAN CARLOS, CA. 94070
;
;
;	IMPLEMENTED BY
;		JOHN S. JAMES
;		P.O. BOX 348
;		BERKELEY, CA. 94701
;
;	This version hacked extensively by:
;		John Comeau <jcomeau@world.std.com>
;		P. O. Box 100632
;		Fort Lauderdale, FL 33310-0632
;
;
;	THIS SYSTEM IS IN THE PUBLIC DOMAIN AND CAN BE USED
;	WITHOUT RESTRICTION.  PLEASE CREDIT THE FORTH INTEREST
;	GROUP IF YOU REPUBLISH SUBSTANTIAL PORTIONS.
;
;
;	THE FORTH INTEREST GROUP / FORTH IMPLEMENTATION TEAM
;	ALSO HAS DEVELOPED NEARLY IDENTICAL VERSIONS OF THIS
;	SYSTEM FOR THE
;		8080
;		6800
;		6502
;		9900
;		PACE
;	
;
;	FOR MORE INFORMATION, WRITE:
;
;		JOHN S. JAMES
;		P.O. BOX 348
;		BERKELEY, CA. 94701
;
;			OR
;
;		FORTH INTEREST GROUP
;		P.O. BOX 1105
;		SAN CARLOS, CA. 94070
;
;
;	'PDP' AND 'RSX' ARE TRADEMARKS OF DIGITAL EQUIPMENT CORPORATION.
.PAGE
;	THIS FORTH SYSTEM HAS
;		- FULL LENGTH NAMES
;		- EXTENSIVE COMPILE-TIME CHECKS AND ERROR MESSAGES
;		- DOUBLE INTEGER I/O
;		- A FORTH ASSEMBLER, PERMITTING STRUCTURED, INTERACTIVE
;		  DEVELOPMENT OF DEVICE HANDLERS, SPEED-CRITICAL 
;		  ROUTINES, AND LINKAGE TO OPERATING SYSTEMS OR TO
;		  SUBROUTINE PACKAGES WRITTEN IN OTHER LANGUAGES.
;		- STRING-HANDLING ROUTINES
;		- A STRING-SEARCH EDITOR
;		- LINKED VOCABULARIES
;		- HOOKS FOR MULTITASKING/MULTIUSER (CURRENTLY SINGLE TASK)
;		- AND AS CURRENTLY CONFIGURED IT RUNS IN A 24K BYTE
;		  TASK IMAGE (THIS INCLUDES BUFFERS, OPERATING-SYSTEM
;		  AREA, AND ROOM FOR SUBSTANTIAL ADDITIONAL FORTH
;		  PROGRAMMING) ON ANY PDP-11 OR LSI-11 CPU, WITH OR
;		  WITHOUT HARDWARE MULTIPLY/DIVIDE.  THIS DISKETTE
;		  WILL BOOT AND RUN STAND-ALONE; ALSO IT CONTAINS A
;		  SOURCE PROGRAM WHICH CAN BE ASSEMBLED TO RUN
;		  UNDER RT-11, RSX-11M, OR STAND-ALONE.  THIS SYSTEM
;		  CAN BE MODIFIED TO INTERFACE WITH ANY OTHER OPERATING
;		  SYSTEM WHICH SUPPORTS READ AND WRITE A CHARACTER,
;		  DETECT A CHARACTER (OPTIONAL), AND READ AND WRITE
;		  A DISK BLOCK.
;
;
;	IT IS ALIGNED WITH THE 1978 STANDARD OF THE FORTH INTERNATIONAL
;	STANDARDS TEAM.
;
;
;
;	RECOMMENDED DOCUMENTATION:
;		- A FORTH LANGUAGE MANUAL.  WE PARTICULARLY RECOMMEND EITHER
;			(A) 'USING FORTH', BY FORTH, INC.
;				OR
;			(B) 'A FORTH PRIMER', BY W. RICHARD STEVENS, KITT
;			    PEAK NATIONAL OBSERVATORY.
;		  EITHER IS AVAILABLE THROUGH THE FORTH INTEREST GROUP,
;		  P.O. BOX 1105, SAN CARLOS, CA. 94070.
;		- PDP-11 FORTH USER'S GUIDE, AVAILABLE FROM JOHN S. JAMES,
;		  ADDRESS ABOVE.
;		- FORTH REFERENCE CARD FOR THE FORTH IMPLEMENTATION TEAM
;		  COMMON MODEL, AVAILABLE FROM FIG.
;		- 'FIG-FORTH INSTALLATION MANUAL', ALSO FROM FIG.
;
;
;
;	ACKNOWLEDGMENTS:
;		     THIS FORTH SYSTEM (IN 'FORTH.MAC') IS A GROUP PRODUCT
;		OF THE FORTH IMPLEMENTATION TEAM OF THE FORTH INTEREST
;		GROUP (P.O. BOX 1105, SAN CARLOS CA. 94070).  THE IMPLEMENTER
;		IS RESPONSIBLE FOR THIS PDP-11 VERSION OF THE MODEL, AND FOR
;		THE SOFTWARE ON SCREENS IN 'FORTH.DAT'.  ALTHOUGH THE LATTER
;		IS NOT AN OFFICIAL RELEASE OF THE F.I.G., THE CONTRIBUTIONS
;		FROM MEMBERS OF THE GROUP ARE TOO NUMEROUS TO CITE
;		INDIVIDUALLY.
;		     IN ADDITION WE APPRECIATE THE PDP-11 CODING
;		IMPROVEMENTS SUGGESTED BY STUART R. DOLE, DOLE & FARMER,
;		PO BOX 142, PETALUMA, CA. 94952; BY PAUL EDELSTEIN;
;		BY RICK STEVENS OF KITT PEAK; AND OTHERS.
;
;macros to cure some minor coding inefficiencies
	.macro	add1	arg
	.if ndf jlc
	add	#1,arg ;only need to use this if checking C flag
	.iff
	inc	arg
	.endc	;jlc
	.endm	add1
;
	.macro	add2	arg
	.if ndf jlc
	add	#2,arg ;not necessary with word-aligned registers
	.iff
	tst	(arg)+ ;the quick way
	.endc	;jlc
	.endm	add2
;
	.macro	add4	arg
	.if ndf jlc
	add	#4,arg
	.iff
	cmp	(arg)+,(arg)+ ;advance by 4
	.endc	;jlc
	.endm	add4
;
	.macro	sub1	arg
	.if ndf jlc
	sub	#1,arg
	.iff
	dec	arg
	.endc	;jlc
	.endm	sub1
;
	.macro	sub2	arg
	.if ndf jlc
	sub	#2,arg
	.iff
	tst	-(arg)
	.endc
	.endm	sub2
;
	.macro	sub4	arg
	.if ndf jlc
	sub	#4,arg
	.iff
	cmp	-(arg),-(arg)
	.endc
	.endm	sub4
;
.PAGE
; ****************************************************************
;
;	BRINGING UP THE SYSTEM
;
;  ****************************************************************
;
;
;
;  TO RUN STAND-ALONE:
;	- BOOT THE DISKETTE LIKE ANY OTHER SYSTEM DISK, FROM DX0.
;	  FORTH SHOULD COME UP AND TYPE 'FIG FORTH' AND THE VERSION
;	  NUMBER.  TEST AS DESCRIBED FOR RT-11 BELOW.
;	- MAKE A COPY OF THE DISK; THIS STAND-ALONE SYSTEM DOES NOT
;	  PROTECT AGAINST ACCIDENTALLY OVERWRITING THE SYSTEM OR THE
;	  SOURCE PROGRAMS.  TO MAKE AN EXACT COPY OF THE ENTIRE DISK,
;	    1. PUT A BLANK DISK INTO THE SECOND DRIVE (DX1).  FOR
;	       SAFETY, SET THE WRITE-PROTECT SWITCH ON THE DRIVE
;	       WHICH CONTAINS THE ORIGINAL SYSTEM DISK.
;	    2. TYPE '38 LOAD', AND CARRIAGE RETURN.  THE SYSTEM SHOULD
;	       RESPOND 'OK'.  THEN TYPE 'COPY' AND RETURN.  EACH OF
;	       THE 77 TRACKS WILL BE READ FROM DX0 AND WRITTEN ON DX1.
;	- NOTE THE LAYOUT OF THE DISKETTE.  IT IS SET UP TO BOOT AND
;	  RUN STAND-ALONE, BUT IT ALSO CONTAINS AN RT-11 DIRECTORY,
;	  AND A MACRO-11 SOURCE PROGRAM 'FORTH.MAC' (WHICH PRODUCED
;	  THIS LISTING).  THIS ALLOWS THE SAME DISK TO BE BOOTED
;	  AND RUN, OR TO PROVIDE SOURCE FOR MODIFICATION AND RE-ASSEMBLY.
;	       AS PROVIDED, THE FILE 'FORTH.DAT' CONTAINS FORTH SCREENS
;	  1-70.  YOU CAN USE LOCATIONS BEYOND 70, BUT THESE WILL 
;	  OVERWRITE THE 'FORTH.MAC' SOURCE PROGRAM.  STAND-ALONE USERS
;	  MAY NEVER NEED TO USE THIS SOURCE, AND MAY WANT TO REMOVE IT
;	  AND USE THE SPACE FOR SOMETHING ELSE.  MAKE A COPY FIRST.
;	- STAND-ALONE USERS CAN ADD THEIR OWN OPERATIONS AND THEN
;	  SAVE A BOOTABLE IMAGE OF THE NEW SYSTEM.  THE NEW OPERATIONS
;	  WILL BE AVAILABLE WHEN THE DISK IS BOOTED IN THE FUTURE.
;	  THE LOADER WHICH IS USED WILL ONLY LOAD IMAGES UP TO 7.9K;
;	  THIS LEAVES SEVERAL HUNDRED BYTES FOR NEW OPERATIONS, WHICH
;	  CAN INCLUDE EXTENDING THE SYSTEM BY BRINGING IN SOURCE OR
;	  OBJECT CODE.  TO SAVE THE CURRENT SYSTEM, EXECUTE 'FORTH DEFINITIONS'
;	  IF NECESSARY TO GET INTO THE FORTH VOCABULARY, THEN 'DECIMAL 34 LOAD'.
;	  SOME WARNING MESSAGES WILL BE PRINTED (MSG #4); THEY CAN BE
;	  IGNORED.
;	- IF YOU DO WANT TO RE-ASSEMBLE THE SYSTEM FOR STAND-ALONE
;	  USE (WHICH MOST USERS SHOULD NEVER FIND NECESSARY),
;	  YOU MUST USE RT-11 TO EDIT AND ASSEMBLE 'FORTH.MAC'.  NOTE
;	  THAT ALTHOUGH THIS LISTING IS ASSEMBLED FOR STAND-ALONE,
;	  THE SOURCE PROGRAM SUPPLIED IS SET FOR RT-11 ASSEMBLY;
;	  COMMENT OUT THE 'RT11' DEFINITION, AND REMOVE THE COMMENTING
;	  ON 'ALONE'.  ASSEMBLE, LINK, AND RUN, AND THE SYSTEM SHOULD
;	  COME UP STAND-ALONE.  IMMEDIATELY REMOVE THE RT-11 SYSTEM DISK
;	  AND PLACE THE FORTH DISK IN DRIVE ZERO.  TO REVISE
;	  THE BOOTABLE IMAGE ON THE FORTH DISK SO THAT YOUR NEW SYSTEM
;	  BOOTS STAND-ALONE, LIST SCREEN 34 (DECIMAL), AND FOLLOW THE
;	  INSTRUCTIONS THERE.  THE RUN TAKES ABOUT ONE MINUTE.
;	- THE BOOTABLE SYSTEM DOES NOT USE HARDWARE MULTIPLY AND DIVIDE.
;	  IF YOU DON'T HAVE RT-11 TO EDIT AND RECOMPILE WITH 'EIS'
;	  CONDITIONAL ASSEMBLY, THE MULTIPLY/DIVIDE ROUTINES CAN BE
;	  PATCHED.  IF YOU PATCH FROM THE KEYBOARD MONITOR, THE
;	  RESTART ADDRESS IS 1000 OCTAL ( COLD START) OR 1004 (WARM
;	  START).  SAVE THE NEW VERSION AS A BOOTABLE SYSTEM, AS
;	  DESCRIBED ABOVE.
;	- THE SKEWED DISK I/O OPERATIONS SKIP TRACK ZERO, FOR COMPATIBILITY
;	  WITH STANDARD PDP-11 SECTOR SKEWING.  THE PHYSICAL READ 
;	  OPERATIONS ('RTS', 'WTS', 'NRTS', 'NWTS') CAN READ ANY SECTOR,
;	  HOWEVER.
;	- ALSO THE SYSTEM AS DISTRIBUTED SKIPS THE FIRST 56 SECTORS
;	  (7 SCREENS) IN ORDER TO SKIP THE BOOT BLOCK AND AN
;	  RT-11 DIRECTORY.  THIS CAUSES THE SCREEN POSITIONS TO BE THE 
;	  SAME FOR STAND-ALONE AND FOR RT-11 (WHICH ACCESSES THE FILE
;	  'FORTH.DAT').  YOU CAN CHANGE THIS BY CHANGING THE VALUE OF
;	  THE VARIABLES 'S-SKIP' (NUMBER OF SCREENS SKIPPED) AND 
;	  'S-USE' (NUMBER OF SCREENS USED BEFORE ACCESSING THE 
;	  SECOND DISK).  THESE VARIABLES CAN BE CHANGED AT ANY TIME,
;	  SO DISK SCREENS CAN BE READ INTO BUFFERS AND THEN FLUSHED
;	  TO DIFFERENT LOCATIONS ON THE DISK.
;	- ADVANCED USERS MAY NOTE THAT THIS SYSTEM IS DESIGNED TO
;	  ALLOW THE MEMORY LAYOUT - NUMBER AND LOCATION OF DISK
;	  BUFFERS, LOCATION OF THE STACK, ETC. - TO BE CHANGED
;	  DYNAMICALLY, WITHOUT REASSEMBLY.
;	  
;
;  TO BRING UP THIS SYSTEM UNDER RT-11:
;	- BE SURE THAT RT-11 IS SELECTED BELOW.  THE LINES DEFINING
;	  'RSX11M' AND 'ALONE' SHOULD BE COMMENTED OUT; 'RT11' SHOULD
;	  NOT BE.  NOTE THAT THIS DISK IS DISTRIBUTED READY FOR RT-11
;	  ASSEMBLY (EVEN THOUGH THIS LISTING IS FOR STAND-ALONE).
;	- IF YOU HAVE HARDWARE MULTIPLY/DIVIDE, ALSO REMOVE THE
;	  SEMICOLON FROM THE LINE DEFINING 'EIS'.
;	- IF YOU ARE USING AN OLDER VERSION OF RT-11 (VERSION 2),
;	  YOU MAY NEED TO USE THE MACROS '..V2..' AND '.REGDEF'.
;	- ASSEMBLE, LINK, AND RUN.  THE SYSTEM SHOULD COME UP AND
;	  TYPE 'FIG-FORTH' AND THE VERSION NUMBER.
;	- TEST THAT IT IS UP BY TRYING SOME ARITHMETIC OR DEFINITIONS, E.G.
;		88 88 * .		(NOTE THAT THE '.' MEANS PRINT)
;		: SQUARE DUP * ;
;		25 SQUARE .
;	  OR TYPE 'VLIST' FOR A LIST OF ALL THE FORTH OPERATIONS IN THE
;	  DICTIONARY.
;	- THE DISK SHOULD WORK IF THE DISKETTE IS IN DRIVE 'DK'.
;	  MAKE SURE THAT 'DK' IS ASSIGNED TO WHATEVER  PHYSICAL
;	  DRIVE YOU ARE USING - OR CHANGE LINE 'RTFILE:' IN
;	  'FORTH.MAC'.  TEST THE DISK BY TYPING
;		1 LIST
;	  WHICH SHOULD LIST THE SCREEN WHICH LOADS THE EDITOR, 
;	  ASSEMBLER, AND STRING ROUTINES.
;	- IN CASE YOU NEED TO GET A LISTING FROM THE ASSEMBLY OF 
;	  'FORTH.MAC' (NOT USUALLY NECESSARY), AND YOUR SYSTEM HAS
;	  ONLY DISKETTES (NO LARGER DISKS), THE 'ALLOCATE' OPTION
;	  IS NECESSARY BECAUSE OF THE SIZE OF THE '.LST' FILE
;	  (AROUND 230 BLOCKS).  FIRST COPY 'FORTH.MAC' ONTO A 
;	  SEPARATE DISKETTE BY ITSELF.  THEN EXECUTE
;		.MACRO /LIST:FORTH.LST /ALLOCATE:300. /NOOBJECT
;	  AND REPLY 'FORTH.MAC' WHEN ASKED FOR 'FILES?'.
;
;
;
;  TO BRING UP THE SYSTEM UNDER RSX-11M:
;	- THE DISKETTE PROVIDED IS IN RT-11 FILE FORMAT.  THE TWO FILES
;	  MUST BE COPIED OFF THE DISKETTE INTO AN RSX DIRECTORY.  THE
;	  'FORTH.DAT' FILE MUST BE COPIED IN IMAGE MODE.  ANY RSX 
;	  DIRECTORY MAY BE USED.  ASSUMING THE DISKETTE IS IN DRIVE 0,
;	  USE THE RSX COMMANDS:
;		>FLX =DX:FORTH.MAC/RT
;		>FLX =DX:FORTH.DAT/RT/IM
;	  INCIDENTALLY, 'FORTH.DAT' IS THE SYSTEM'S 'VIRTUAL MEMORY' 
;	  FILE, USED FOR DISK I/O.  THE REST OF THE SYSTEM (THIS
;	  PROGRAM ALONE) CAN RUN INDEPENDENTLY, EVEN IF 'FORTH.DAT'
;	  IS NOT AVAILABLE.
;	- EDIT 'FORTH.MAC' TO SELECT RSX ASSEMBLY.  CHANGE THE SEMICOLON
;	  TO COMMENT OUT 'RT11' NOT 'RSX11'.  LET 'EIS' BE DEFINED IF
;	  YOU HAVE HARDWARE MULTIPLY/DIVIDE.
;	- ASSEMBLE, TASK BUILD, AND RUN.  TEST AS WITH RT11 ABOVE.
;	- THE DISK I/O SHOULD WORK IF 'FORTH.DAT' IS IN THE DEFAULT
;	  DEVICE AND DIRECTORY.  TEST AS ABOVE.
;
;
;
;  THE SYSTEM AS SUPPLIED RESERVES 8000. BYTES FOR YOUR FORTH 
;  PROGRAMMING AND STACK.  THIS IS ENOUGH FOR SUBSTANTIAL PROJECTS.
;  (NOTE THAT THE EDITOR, ASSEMBLER, AND STRING PACKAGE, IF LOADED,
;  USE MORE THAN 5K OF THIS.)  TO CHANGE THIS MEMORY SIZE, CHANGE
;  THE '8000.' WHICH IS IN THE LINES FOLLOWING THE LABEL 'DP:',
;  NEAR THE END OF THIS PROGRAM.  INCIDENTALLY, VERY FEW JOBS
;  (E.G. RECURSION) WILL EVER USE MORE THAN 100 WORDS OF THIS SPACE
;  FOR THE STACK; THE REST OF THE SPACE IS AVAILABLE FOR A STRING
;  STACK (IF USED) OR FOR YOUR PROGRAMS - AND FORTH OBJECT CODE IS
;  CONSIDERABLY MORE COMPACT THAN ASSEMBLY.
;
;
;
;  THE FORTH VIRTUAL FILE 'FORTH.DAT' IS USED FOR STORING SOURCE
;  PROGRAMS (OR DATA).  THIS FILE HAS 70 1-K SCREENS (1-70),
;  I.E. 140 PDP-11 DISK BLOCKS.   SCREENS 4 AND 5 ARE USED BY THE 
;  SYSTEM FOR STORING ERROR AND WARNING MESSAGES.  SCREENS 6-30
;  CONTAIN A TEXT EDITOR, ASSEMBLER, STRING PACKAGE, AND MISCELLANEOUS 
;  EXAMPLES.  SCREENS 40 THROUGH 47 CONTAIN A BINARY STAND-ALONE
;  SYSTEM (NOT USED UNDER RT-11 OR RSX-11M).  USERS MAY WANT
;  TO SAVE THEIR SOURCE PROGRAMS AND DATA IN THE BLANK SCREENS.
;  THE SIZE OF THIS FORTH SCREENS FILE ('FORTH.DAT') CAN BE INCREASED
;  IF NEEDED.  IF THE SYSTEM IS TO BE BOOTED STAND-ALONE, THE LOCATION
;  OF THE SYSTEM BINARY IMAGE ON THE DISK MUST NOT BE CHANGED;
;  THEREFORE, IF THE DISK IS TO BE USED TO RUN STAND-ALONE, DO NOT
;  USE RT-11 TO MOVE 'FORTH.DAT' TO ANOTHER PLACE ON THE DISK.
;
;
;
;
;
;  NOTE THAT THE RT-11 AND RSX-11M SYSTEMS DO NOT ECHO CHARACTERS
;  WHICH ARE INPUT FROM THE TERMINAL.  INSTEAD, THEY LET THE OPERATING
;  SYSTEM (RT-11 OR RSX-11M) ECHO THEM.  THIS IS DONE SO THAT TYPING
;  CONVENTIONS WILL BE THE SAME AS THE USER IS FAMILIAR WITH.  ALSO, 
;  TO AVOID SWAPPING DELAYS, THE RSX VERSION OF 'KEY' READS A LINE OF
;  CHARACTERS AT A TIME.
;
;
;
;
;  CHANGE THESE LINES TO CONTROL CONDITIONAL ASSEMBLY:
;
;RT11=1		; COMMENTED OUT UNLESS RT-11
RSX11=1	; COMMENTED OUT UNLESS RSX11M
;ALONE=1		; COMMENTED OUT UNLESS STAND-ALONE
EIS=1		; COMMENTED OUT UNLESS HARDWARE MULTIPLY-DIVIDE-XOR-SOB
;LINKS=1	; COMMENTED OUT UNLESS SUBROUTINE LINKAGE FROM
;			FORTH TO OTHER LANGUAGES
.if df jlc ;enable/disable various attempts at optimization
newabs=1
newmin=1
newmax=1
.if df eis ;some optimizations not doable without EIS instructions
;as of 5/28/96, newpfind and newcreate don't work
newxdo=1
newdigit=1
;newpfind=1 ;newpfind will choke on first use of ':'
newcmove=1
newzequ=1
newzless=1
newtoggle=1
newcat=1
newspace=1
;newcreate=1 ;newcreate will lock up after first CRLF
newnfa=1 ;new versions of NFA and PFA should work with old CREATE...
newpfa=1
newiddot=1
cmdline=1 ;get input from command line, .DAT filename from taskname
newtio=1 ;I/O using two separate LUNs for input and output
.if df newtio
	stdin=5
	stdout=6 ;make sure TKB assigns both LUNs to TI0:
.endc	;newtio
.if df newcreate ;new CREATE sets MSB on final char regardless of alignment
	newnfa=1 ;NFA and PFA must be modified to work with it...
	newpfa=1
.endc	;newcreate
.endc	;eis
.endc	;jlc
;
;.PAGE
; ****************************************************************
;
;		VARIATIONS FROM F.I.G. MODEL
;
; ****************************************************************
;
;
;  'FIRST' AND 'LIMIT' HAVE BEEN MADE USER VARIABLES, NOT CONSTANTS.
;  THEREFORE WHEN THEY ARE USED, 'FIRST @' AND 'LIMIT @' ARE
;  REQUIRED.
;
;  ';CODE' AND 'FORTH' ARE NOT PURE CODE, SO THEY WERE MOVED TO THE
;  END OF THE DICTIONARY.  THIS IS SO THE BULK OF THE DICTIONARY 
;  COULD BE PUT IN PROM OR USED RE-ENTRANTLY.
;
;  THE MACHINE-INDEPENDENT I/O SECTION WAS MOVED TO NEAR THE END OF
;  THE DICTIONARY, BECAUSE IT IS NOT ALWAYS PURE CODE, AND ALSO TO
;  ALLOW THE I/O TO BE REDEFINED WITHOUT REASSEMBLY.
;
;  THIS SYSTEM MUST TEST FOR FIRST-TIME-THROUGH TERMINAL AND DISK
;  I/O, TO AVOID ERRONEOUS ATTEMPT TO OPEN FILES TWICE AT LATER COLD
;  STARTS.  IT CLEARS DISK BUFFERS AT COLD START.
;
.PAGE
; ****************************************************************
;
;		SET UP REGISTERS AND MACROS.
;
; ****************************************************************
;
;
W=%2		; TEMPORARY USED BY 'NEXT' MACRO (THE INNER INTERPRETER)
U=%3		; POINTER TO THE USER AREA
IP=%4		; FORTH INSTRUCTION COUNTER
S=%5		; FORTH STACK POINTER
RP=SP		; FORTH RETURN-STACK POINTER
;
;  NOTE - CODE ROUTINES CAN USE REGISTERS 0, 1, 2, AND 5, WITHOUT
;  RESTORING THEM. (6/16/96 corrected typo - it said 0, 1, _4_, and 5 - jc)
;
;
;  MACRO DEFINITIONS
;
;
;
;  THE 'HEAD' MACRO CREATES A FORTH DICTIONARY HEADER.  ITS ARGUMENTS ARE:
;   (1)	LENGTH BYTE - THE LENGTH OF THE NAME BEING DEFINED.  THE SIGN BIT
;	OF THE LENGTH BYTE MUST BE SET, SO THAT THE SYSTEM WILL RECOGNIZE
;	THE END OF A VARIABLE-LENGTH NAME FIELD; THEREFORE THE LENGTH BYTE
;	IS GIVEN AS 200 OCTAL PLUS THE LENGTH.  IF THE OPERATION IS
;	IMMEDIATE, THE BIT NEXT TO THE SIGN BIT IS ALSO SET, SO THE LENGTH
;	BYTE IS GIVEN AS 300 OCTAL PLUS THE LENGTH.
;  (2)	NAME - THE NAME OF THE OPERATION BEING DEFINED.
;  (3)	LCHAR - THE ASCII VALUE OF THE LAST CHARACTER OF THE NAME, WITH THE
;	SIGN BIT SET.  THE NAME FIELD MUST HAVE AN EVEN LENGTH (INCLUDING
;	THE LENGTH BYTE), SO IF THE NUMBER OF CHARACTERS IN THE NAME IS
;	EVEN, 'LCHAR' WILL BE GIVEN AS 240 (200 PLUS CODE FOR A SPACE).
;  (4)	LABEL - THE ASSEMBLY-LANGUAGE LABEL ASSOCIATED WITH THE 'CODE FIELD'
;	OF THIS DICTIONARY HEADER.  THESE LABELS ARE USED IN THE PRECOMPILED-
;	FORTH SECTION OF THE SYSTEM.  WHEN POSSIBLE, THE FORTH OPERATION 
;	NAME ITSELF IS USED AS THE ASSEMBLY LABEL; OTHERWISE AN ABBREVIATION
;	IS USED.  BY CONVENTION, THESE NAMES ARE LIMITED TO FIVE CHARACTERS,
;	FOR CONSISTENCY AMONG VARIOUS ASSEMBLERS FOR DIFFERENT MICROPROCESSORS.
;	(THE FORTH IMPLEMENTATION TEAM USES THE SAME LABELS IN ALL OF ITS
;	VERSIONS.)
;   (5)	CODE - POINTER TO THE MACHINE-LANGUAGE "CODE ROUTINE" ASSOCIATED 
;	WITH THIS OPERATION TYPE OR DATA TYPE.  E.G. FOR ANY COLON DEFINITION,
;	THIS ARGUMENT IS 'DOCOL', THE LABEL OF A FIVE-INSTRUCTION ASSEMBLY
;	ROUTINE WHICH USES THE RETURN STACK TO HANDLE THE NESTED EXECUTION
;	OF ANOTHER LEVEL OF FORTH OPERATIONS.  FOR ANY CONSTANT, THIS CODE
;	ROUTINE IS 'DOCON', AND SIMILARLY FOR ALL OTHER DATA TYPES.
;		THE CODE ARGUMENT MAY BE OMITTED.  IN THAT CASE, THE 'HEAD'
;	MACRO LEAVES THE CODE FIELD POINTING TWO BYTES BEYOND ITSELF, WHERE
;	MACHINE-LANGUAGE CODE MUST BEING - AND THE OPERATION SO DEFINED IS
;	CALLED A "PRIMITIVE".  THE "NUCLEUS SECTION" OF THIS VERSION OF
;	FORTH CONTAINS ABOUT 45 PRIMITIVES, FROM WHICH THE WHOLE SYSTEM
;	IS BUILT; IN EFFECT, THESE PRIMITIVES DEFINE THE VIRTUAL FORTH
;	MACHINE.  (A FEW OPERATIONS IN THE "PRECOMPILED FORTH" SECTION
;	OF THE SYSTEM HAVE BEEN REPLACED WITH PRIMITIVES, TO OPTIMIZE
;	EXECUTION SPEED.  AND WHEN A FORTH ASSEMBLER IS ADDED TO THIS
;	SYSTEM, USERS WILL BE ABLE TO DEFINE THEIR OWN PRIMITIVES DIRECTLY
;	IN FORTH, IMMEDIATELY READY FOR EXECUTION.)
;
;  THE 'HEAD' MACRO CREATES A FORTH HEADER CONSISTING OF
;	LENGTH BYTE - SIGN BIT SET
;	NAME OF THE OPERATION - VARIABLE LENGTH - SIGN BIT SET ON LAST CHAR.
;	LINK FIELD, WHICH POINTS TO THE BEGINNING OF THE PREVIOUS DICTIONARY
;		HEADER (USED AT COMPILE TIME)
;	CODE POINTER.
;
LINK=0		; LAST LINK FIELD IS 0, INDICATING END OF THE DICTIONARY.

;
	.MACRO	HEAD,LENGTH,NAME,LCHAR,LABEL,CODE
LINK2=.
	.BYTE	LENGTH
	.ASCII	^NAME^
	.EVEN
.=.-1
	.BYTE	LCHAR	; LAST CHARACTER OF NAME (OR BLANK FILL),
		;  PASSED IN OCTAL, WITH HIGH BIT SET.
	.WORD	LINK
LINK=LINK2
LABEL:	.IF NB CODE
	.WORD	CODE
	.IFF
	.WORD	.+2
	.ENDC
	.ENDM
;
;The DEFINE macro creates a header with just two arguments, the name itself
; and the assembly label. The bit manipulation is done by MACRO-11.
;If JLC is undefined, the header created will be the same as that created by
; John S. James' HEAD macro. Otherwise the sign bit will be set on the last
; character of the name itself, as in other FORTH implementations.
nf.msb=200 ;define bits in Name Field
nf.precedence=100
nf.smudge=40
	.macro	.immediate
precedence=nf.precedence
	.endm	.immediate
;
precedence=0	;don't set PRECEDENCE bit unless .IMMEDIATE macro is invoked
	.macro	define label,name,code,value
link2=.
	.if idn ^|name| ^|null| ;special case for null
	.byte 1!nf.msb!precedence,0!nf.msb
	.iff
	.nchr	len,^|name| ;get length of the name
	.byte	len!nf.msb!precedence
$$$=0	;define current place in name
	.irpc	char,^|name| ;do for each character of name
$$$=$$$+1 ;increment the pointer
	.if eq len-$$$ ;final character?
;if name length is odd, it is word aligned
	 .if ne len&1
	  .byte ''char!nf.msb ;set most significant bit if so
	 .iff ;even length, so we have to pad it
	  .if df newcreate ;new style, still set bit on last char of name
	   .byte ''char!nf.msb,40
	  .iff ;old style, set sign bit on pad byte
	   .byte ''char,40!nf.msb
	  .endc ;newcreate
	 .endc ;ne len&1
	.iff
	.byte	''char	;otherwise just the character
	.endc	;final character
	.endr
	.endc	;null
precedence=0	;reset P bit until .IMMEDIATE is invoked
	.word	link	;backwards link to previous word
link=link2	;set link up for next time
label:	.if nb code ;if programmer specified the code...
	.word	code ;use it...
	.iff	;otherwise assume primitive
	.word	.+2 ;code follows immediately
	.endc
	.if nb value ;for CONST declarations
	.word	value
	.endc
	.endm	define
;
	.macro	.pdotq	string
;	.list	me,meb	;until debugged, see how it expands
	.nchr	len,^|string| ;get count of characters in the string
	.word	pdotq	;FORTH word to show the string
	.byte	len	;counted string follows...
	.ascii	|string|
	.even	;align on word boundary
;	.nlist	me,meb
	.endm	.pdotq
;
;
;  THE 'NEXT' MACRO TRANSFERS CONTROL FROM ONE FORTH OPERATION TO THE
;  'CODE ROUTINE' OF THE NEXT.  NOTICE THAT ONLY TWO INSTRUCTION
;  EXECUTIONS ARE REQUIRED TO TRANSFER CONTROL FROM USEFUL OPERATIONS
;  OF ONE FORTH PRIMITIVE TO THOSE OF THE NEXT.
;
	.MACRO	NEXT
	MOV	(IP)+,W
	JMP	@(W)+
	.ENDM
;
;
;  MACRO CALLS
;
;
	.IFDF	RT11
	.MCALL	.RCTRLO,.TTYIN,.TTINR,.TTYOUT,.EXIT,.TRPSET
	.MCALL	.SETTOP,.DSTATUS,.FETCH,.LOOKUP,.READW,.WRITW
	.ENDC
;
;
	.IFDF	RSX11
	.if ndf jlc
	.MCALL	QIOW$C,EXIT$S,ALUN$C,ASTX$S,SVTK$S
	.MCALL	FDBDF$,FDRC$A,FDBK$A,FDOP$A,FSRSZ$
	.MCALL	OPEN$M,READ$,WRITE$,WAIT$,CLOSE$
	.MCALL	QIOW$
	.iff	;jlc
	.enable mcl	;lazy man's way
	.endc	;jlc
	.ENDC
.PAGE
; ****************************************************************
;
;		START-UP TABLE
;
; ****************************************************************
;
;  AT STARTUP, MOST OF THESE VALUES ARE MOVED INTO THE USER AREA
;  (STARTING AT 'XDP:'); THEY ARE NORMALLY ACCESSED THERE.  THE VALUES
;  HERE ARE  NOT USUALLY CHANGED, BUT THEY MAY BE CHANGED E.G. TO
;  CONTROL WHAT HAPPENS AT COLD START.  THIS TABLE COULD BE MOVED OUT OF
;  LOW MEMORY IF NECESSARY FOR ROM SYSTEMS.
;
;
;
GFORTH::			; GLOBAL LABEL - NORMALLY NOT USED
ORIGIN:	JMP	CENT		; COLD START ENTRY POINT
	JMP	WENT		; WARM START ENTRY ADDRESS
;  NOTE - COLD START WIPES OUT ANY NEW DICTIONARY DEFINITIONS, AND
;  THEN DOES A WARM START.  WARM START CLEANS UP STACKS, TERMINAL
;  BUFFER, ETC.
	.WORD	11		; CPU (origin+8)
	.WORD	0		; REVISION (origin+10.)
	.WORD	TASK-10		; POINTER TO LATEST WORD DEFINED (+12.)
	.WORD	10		; BACKSPACE CHARACTER (+14.)
	.WORD	XUP		; POINTER TO USER AREA (+16.)
;  NOTE - THE USER AREA IS A HOOK IN THIS SYSTEM TO ALLOW MULTITASKING
;  TO BE ADDED LATER.
	.WORD	XS0		; POINTER TO BEGINNING OF THE STACK (+18.)
	.WORD	XR0		; POINTER TO BEGINNING OF RETURN STACK (+20.)
	.WORD	XTIB		; POINTER TO TERMINAL INPUT BUFFER (+22.)
	.WORD	31.		; MAXIMUM NAME-FIELD WIDTH, NORMALLY 31 (+24.)
	.WORD	0		; WARNING MODE; 0=ERROR #, 1=DISK MESSAGE (+26.)
;  NOTE - WARNING MODE INITIALIZED TO ZERO, IN CASE DISK ISN'T UP.
	.WORD	XDP		; FENCE TO PROTECT AGAINST ACCIDENTAL (+28.)
				; 'FORGET' OF THE SYSTEM.
	.WORD	XDP		; POINTER TO NEXT AVAILABLE DICTIONARY (+30.)
				; LOCATION (RETURNED BY 'HERE').
	.WORD	XXVOC		; POINTER TO INITIAL VOCABULARY LINK (+32.)
	.WORD	DSKBUF		; INITIALIZE 'FIRST' (+34.)
	.WORD	ENDBUF		; INITIALIZE 'LIMIT' (+36.)
	.if df newtio ;set up user variables for LUNs in RSX
	.word	stdin	;standard input LUN (+38.)
	.word	stdout	;standard output LUN (+40.)
	.iff
	.WORD	0		; AVAILABLE
	.WORD	0		; AVAILABLE
	.endc	;newtio
;
.PAGE
; ****************************************************************
; 
;		NUCLEUS
;
; ****************************************************************
;
;
;
;  THE NUCLEUS CONTAINS THE PRIMITIVES FROM WHICH THE SYSTEM IS BUILT.
;
;
;
;Push following literal value onto operand stack	; ***** LIT
	define	lit,LIT
	mov	(ip)+,-(s)
	next
;Execute FORTH word whose code address is on stack	; ***** EXECUTE
	define	execute,EXECUTE
	mov	(s)+,w
	jmp	@(w)+
;Branch to address whose offset follows                 ; ***** BRANCH
	define	branch,BRANCH
	add	(ip),ip
	next
;Branch if stack top is false (zero)                    ; ***** 0BRANCH
	define	zbranch,0BRANCH
	tst	(s)+	;test TOS and throw it away
	bne	10$	;if nonzero, skip branch offset
	add	(ip),ip	;otherwise branch to indicated offset
	next
10$:	add2	ip	;skip branch offset, just go to next CFA
	next
;Increment loop index by 1, branch if below limit	; ***** (LOOP)
	define	xloop,(LOOP)
	inc	(rp)	;bump index
	cmp	(rp),2(rp) ;have we reached limit?
	bge	10$	;finish loop if so; BGE in case limit was 0
	add	(ip),ip	;loop by adding in-line branch offset to IP
	next
10$:	add4	rp	;throw away index and limit
	add2	ip	;skip past in-line loop branch offset to following CFA
	next
;Same as (LOOP) but incs by value at stack top		; ***** (+LOOP)
	define	xploop,(+LOOP)
	add	(s),(rp) ;update index by value at stack top
	tst	(s)+	;throw away the addend and see if negative
	blt	20$	;if so, test differently
	cmp	2(rp),(rp) ;are we above limit?
	ble	10$	;if so, terminate loop
	add	(ip),ip ;else add branch offset and continue loop
	next
10$:	add4	rp
	add2	ip
	next
20$:	cmp	(rp),2(rp) ;see if went down below limit (negative increment)
	ble	10$	;done if less or equal
	add	(ip),ip	;else loop back around
	next
;Set up DO limit and index				; ***** (DO)
	define	xdo,(DO)
	mov	2(s),-(rp) ;limit first
	.if df newxdo
	mov	(s)+,-(rp) ;store index, then toss it
	add2	s	;now throw away limit, still on return stack
	.iff	;old style
	mov	(s),-(rp)
	add4	s
	.endc	;newxdo
	next
;Return current loop index on operand stack		; ***** I
	define	i,I
	mov	(rp),-(s) ;nondestructive move from return stack
	next
;
;( ASCII-digit base ==> digit-value true (or false))	; ***** DIGIT
	define	digit,DIGIT
;Accepts "numbers" from 0-9 and A-Z (capitals only). The base is only used to
; check validity, since with only one digit there is no radix computation
; necessary - the only stipulation is that the number be less than the base;
; e.g., in HEX the highest digit is F (15.), and in base 36, Z (35.).
	.if df newdigit
	sub	#'0,2(s) ;lowest acceptable digit is 0
	bcs	20$	;so give up if it's lower
	cmp	2(s),#9. ;within decimal range?
	ble	10$	;continue if so
	sub	#7,2(s) ;assume it's A to Z, adjust accordingly
	cmp	2(s),#10. ;if so, it must be at least 0xA=10.
	blt	20$	;error if not
10$:	cmp	2(s),(s) ;must be less than base
	bge	20$	;error if not
	mov	#1,(s)	;return TRUE flag
	next
20$:	tst	(s)+	;throw one arg off stack
	clr	(s)	;and zero out flag to FALSE
	next
	.iff	;old version
	sub	#60,2(s)
	cmp	2(s),#11
	ble	10$
	sub	#7,2(s)
	cmp	2(s),#12
	blt	20$
10$:	tst	2(s)
	blt	20$
	cmp	2(s),(s)
	bge	20$
	mov	#1,(s)
	next
20$:	add	#2,s
	clr	(s)
	next
	.endc	;newdigit
;Used by compiler to find a word in the dictionary.	; ***** (FIND)
	define	pfind,(FIND)
;(string-address NFA ==> PFA length true (or false))
; string-address is pointer to counted string of name being sought
; NFA is the name-field-address of dict word at which to begin the search
; PFA is the parameter-field-address of the dict entry found, flag=true
; If word is not found, only the flag (FALSE) is returned
	mov	(s)+,r0	;dictionary address
	mov	(s)+,r1	;string address
	mov	s,-(rp) ;preserve registers, R5...
	mov	ip,-(rp) ;R4...
	mov	u,-(rp) ;and R3, no need to save W register (R2)
	clr	-(rp)	; space to store length byte
;prepare r2 for fast compare
	mov	(r1),r2		;get first two chars of search string
	bic	#100200,r2	;clear MSBs of first two bytes
;first try a fast compare of count+first letter to eliminate most words
;
10$:	mov	(r0),r3	;get what's at current dict pointer
	bic	#100300,r3 ;clear MSBs and Precedence bit
;note: if the smudge bit is set, this will not find it...
	cmp	r2,r3	;does it match the search string?
	beq	30$	;skip if not, no fast elimination possible
	.if ndf newpfind
14$:	tst	(r0)+	;skip to end of this name
	bpl	14$	;marked by sign bit set
	tst	(r0)	;see if end of dictionary
	beq	90$	;failed if so
	mov	(r0),r0 ;else link to next entry
	.iff
	movb	r3,r3	;clear high byte of length word
	bicb	#1,r3	;first round down to word alignment
	tst	(r3)+	;then advance to account for count byte itself
	add	r3,r0	;skip to end of word
20$:	mov	(r0),r0	;link to preceding word
	beq	90$	;if zero instead of pointer, search failed
	.endc	;newpfind
	br	10$	;try with next word
30$:	.if ndf newpfind
	mov	(r0),(rp) ;save length byte
	mov	r1,r5	;copy search string address
	br	36$	;skip to loop end
32$:	tst	(r5)+	;skip two bytes already compared in searched word
	mov	(r5),r4	;get next two bytes
	mov	(r0),r3	;of both strings
	bic	#100000,r3 ;clear end-of-name bit if set
	cmp	r3,r4	;match?
	bne	14$	;if not, skip to next dictionary entry
36$:	bit	#100000,(r0)+ ;is it the end of the name entry?
	beq	32$	;continue if not
	.iff	;faster method (?)
	movb	(r0)+,(rp) ;save length byte with MSBs intact
	mov	r1,r5	;copy search string address
;Note that we cleared the high bit and precedence bit, and the smudge bit
; cannot be set or it wouldn't have matched. So the low byte of R3 is
; definitely the correct length.
	decb	r3	;account for byte already compared
	beq	45$	;if that's all, successful match!
	tst	(r5)+	;skip two bytes in searched word, count & 1st char
	inc	r0	;and in dict entry (we already autoINCed once above)
	movb	r3,r3	;clear high byte of count
40$:	movb	(r0)+,r4 ;get next byte of dict entry
	bicb	#200,r4 ;clear any end-of-string marker
	cmpb	r4,(r5)+ ;see if matched
	bne	50$	;jump out if not
	sob	r3,40$	;loop till no more to compare
45$:	;successful match
	inc	r0	;make sure to clear odd byte
	bic	#1,r0	;but align on word boundary (at link word)
	cmp	(r0)+,(r0)+ ;skip link word and WA, point to PFA
	.endc	;newpfind
	mov	(rp)+,r2 ;get length byte
	mov	(rp)+,u ;restore other registers
	mov	(rp)+,ip
	mov	(rp)+,s
	.iif ndf newpfind, add #4,r0 ;adjust R0 in JSJ's version
	mov	r0,-(s) ;place on operand stack for caller
	.iif ndf newpfind, bic #177400,r2 ;clear high byte in JSJ's version
	mov	r2,-(s) ;length byte next
	mov	#1,-(s)	;true flag indicates success
	next
;Here when we fail during char-by-char compare; for example, "BLAH" with "BLAB"
; will pass the fast test above, then pass the "L", "A", and fail at "H"-"B";
; we then arrive here with r3=1 and R0 pointing to the odd byte before the link
; word.
	.if df newpfind
50$:	add	r3,r0	;skip to link word
	bic	#1,r0	;in case keyword ended on word boundary
	br	20$	;loop back around
	.endc	;newpfind
90$:	;failed to find a match
	tst	(rp)+	;throw away length byte
	mov	(rp)+,u ;restore FORTH working registers
	mov	(rp)+,ip
	mov	(rp)+,s
	clr	-(s)	;indicate failure
	next
;Isolate next input word				; ***** ENCLOSE
	define	enclose,ENCLOSE
;(start-address delimiter ==> address offset end next-character)
	mov	(s),r0	;delimiter, generally space (040)
	mov	2(s),r1	;starting address
	sub4	s
10$:	cmpb	(r1)+,r0 ;search forward for nondelimiter
	beq	10$	;just keep skipping till something else comes along
	sub1	r1
	mov	r1,4(s)	;and store its address as OFFSET
20$:	tstb	(r1)	;was that nondelimiter a null?
	beq	40$	;special treatment if so
	cmpb	(r1)+,r0 ;otherwise search for end of token
	bne	20$	;skip until delimiter or null found
	mov	r1,(s)	;and when found, store following address as NEXT-CHAR
	sub1	r1
30$:	mov	r1,2(s)	;store end of token (first delimiter past token)
	mov	6(s),r1	;now get the starting address...
	sub	r1,(s)	;and make the 3 results offsets from that...
	sub	r1,2(s)	;...
	sub	r1,4(s)	;...
	next
40$:	mov	r1,(s)	;here if null found
	cmp	r1,4(s)	;is the null the first nondelimiter found?
	bne	30$	;done if not
	add1	r1
	br	30$	;finish up
;
;  The next 4 headers point to installation-dependent terminal i/o
;  routines.
;
	define	emit,EMIT,pemit				; ***** EMIT
	define	key,KEY,pkey				; ***** KEY
	define	qterminal,?TERMINAL,pqter		; ***** ?TERMINAL
	define	cr,CR,pcr				; ***** CR
;
;Move string from source to destination			; ***** CMOVE
	define	cmove,CMOVE
;(source destination n ==>) move bytes in memory
	.if df newcmove
	mov	(s)+,r2 ;get count n
	beq	20$	;quit if nothing to do
	mov	(s),r1	;destination
	mov	2(s),r0 ;source
10$:	movb	(r0)+,(r1)+ ;store the string...
	sob	r2,10$	;...one character at a time.
20$:	cmp	(s)+,(s)+ ;clean up stack
	next
	.iff
	tst	(s)	;anything to do?
	beq	20$	;quit if not
	mov	2(s),r0 ;get args into registers...
	mov	4(s),r1	;...
10$:	movb	(r1)+,(r0)+ ;move the string
	dec	(s)	;count down
	bne	10$	;loop till done
20$:	add	#6,s	;clean stack
	next
	.endc	;newcmove
;Unsigned multiplication with 32-bit product		; ***** U*
	define	ustar,U* ;(n1 n2 ==> product)
	jsr	pc,umult
	next
;
umult:
; the values to multiply are on the stack.
	mov	(s)+,r2	;get multiplier
	mov	#16.,-(rp)	; set loop count
	clr	r0	;clear result registers
	clr	r1	;...
10$:	rol	r1	;rotate result registers left
	rol	r0	;...
	rol	r2	;then rotate the multiplier
	bcc	20$	;if a bit didn't shift out the top end, skip it
	add	(s),r1	;otherwise add the multiplicand to the result registers
	adc	r0	;...
20$:	dec	(rp)	;decrement the loop count
	bne	10$	;loop till done
	mov	r1,(s)	;store the result
	mov	r0,-(s)	;...
	tst	(rp)+	;pop temporary
	rts	pc
;
;Unsigned 32-bit division				; ***** U/
	define	uslash,U/
	jsr	pc,udiv
	next
udiv:
;  the values to divide are on the stack
	mov	(s)+,r2	;divisor
	mov	(s)+,r0	;dividend, high word...
	mov	(s)+,r1	;low word
	mov	#16.,-(s) ;loop count
10$:	asl	r1	;longword shift dividend left...
	rol	r0	;...
	beq	20$	;no need to subtract if zero
	sub	r2,r0	;otherwise subtract divisor
	inc	r1	;set the bit
	bcc	20$	;did subtraction force a borrow out?
	add	r2,r0	;must restore if so...
	dec	r1	;...
20$:	dec	(s)	;loop sixteen times
	bne	10$	;loop till done
	tst	(s)+	;pop to discard count
	mov	r0,-(s)	;remainder
	mov	r1,-(s)	;quotient
	rts	pc
;
;bitwise AND.  ( n1 n2 ==> n3).				; ***** AND
	define	and,AND
	com	(s)	;complement, then clear bits
	bic	(s)+,(s) ;...
	next
;bitwise OR						; ***** OR
	define	or,OR
	bis	(s)+,(s) ;unconditionally set bits of n1 into n2
	next
;logical exclusive OR					; ***** XOR
	define	xor,XOR
	.ifdf	eis	;hardware XOR exists, use it!
	mov	(s)+,r0 ;needs to be in general register
	xor	r0,(s)	;toggle the bits at addr
	.iff
	mov	(s),-(rp) ;copy the toggle bits onto return stack
	bic	2(s),(rp) ;clear any bits already set in destination word
	bic	(s)+,(s) ;clear toggle bits in destination word
	bis	(rp)+,(s) ;then set any bits which weren't set previously
	.endc
	next
;Return operand stack pointer				; ***** SP@
	define	spat,SP@
;cannot use MOV S,-(S) because result ambiguous in PDP architecture
	mov	s,r1	;move into temp register
	mov	r1,-(s)	;then autodecrement to store
	next
;Reset stack pointer to startup	value			; ***** SP!
	define	spstore,SP!
	mov	6(u),s	;offset 6 in user area
	next
;Reset return stack pointer to startup value		; ***** RP!
	define	rpstore,RP!
	mov	origin+20.,rp ;fixed offset from start of code
	next
;Terminate a high level definition			; ***** ;S
	define	semis,<;S>
	mov	(rp)+,ip ;get next CFA from return stack
	next
;Force an exit to a DO loop				; ***** LEAVE
	define	leave,LEAVE
	mov	(rp),2(rp) ;works by making index=limit
	next
;Transfer TOS to TOR					; ***** >R
	define	tor,^/>R/ ;make special delimiter
	mov	(s)+,-(rp) ;pop operand stack after moving
	next
;Transfers TOR to TOS					; ***** R>
	define	fromr,^/R>/
	mov	(rp)+,-(s) ;opposite of >R
	next
;Push a copy of the TOR to TOS				; ***** R
	define	r,R
	mov	(rp),-(s) ;move without popping
	next
;Test for top stack element zero, return TRUE if so	; ***** 0=
	define	zequ,0=
	tst	(s)	;see if top element zero
	beq	10$	;make it 1 if so
	clr	(s)	;else make it false (zero)
	br	20$	;join common code
10$:	.if df newzequ
	inc	(s)	;known to be zero, so just inc it
	.iff
	mov	#1,(s)	;make it TRUE
	.endc	;newzequ
20$:	next
;Test for top stack element less than zero		; ***** 0<
	define	zless,0<
	.if df newzless
	rol	(s)	;put sign bit into carry flag
	mov	#0,(s)	;can't use CLR, that would wipe out carry flag
	rol	(s)	;slip carry into LSB
	.iff
	tst	(s)	;check sign bit
	bmi	10$	;skip if less
	clr	(s)	;else mark false
	br	20$	;join common code
10$:	mov	#1,(s)	;mark TRUE
20$:	.endc	;newzless
	next
;Add top two stack elements, return sum			; ***** +
	define	plus,+
	add	(s)+,(s) ;(n1 n2 ==> n3)
	next
;Add two longwords on stack				; ***** D+
	define	dplus,D+
	add	2(s),6(s) ;low words were pushed first
	adc	4(s)	;add any carry to high word
	add	(s),4(s)
	add4	s
	next
;Change sign						; ***** MINUS
	define	minus,MINUS
	neg	(s)	;use hardware instruction for two's complement
	next
;Change sign of longword on stack			; ***** DMINUS
	define	dminus,DMINUS
	neg	(s)	;first get two's complement of high word
	neg	2(s)	;then low word
	sbc	(s)	;subtract any carry (???)
	next
;Copy 2nd stack element to top of stack			; ***** OVER
	define	over,OVER ;(n1 n2 ==> n1 n2 n1)
	mov	2(s),-(s)
	next
;Discard top of stack (n ==>)				; ***** DROP
	define	drop,DROP
	add2	s
	next
;Swap top two stack elements (n1 n2 ==> n2 n1)		; ***** SWAP
	define	swap,SWAP
	mov	2(s),r1 ;copy 2nd element into temp register
	mov	(s),2(s) ;copy first element into 2nd element
	mov	r1,(s) ;then temp register into first element
	next
;Make a copy of top stack element			; ***** DUP
	define	dup,DUP
	mov	(s),-(s) ;simple 16-bit copy
	next
;Plus-store (n addr ==>) Add n to number at addr	; ***** +!
	define	pstore,+!
	add	2(s),@(s)
	add4	s
	next
;Exclusive-OR bit pattern into memory byte		; ***** TOGGLE
	define	toggle,TOGGLE ;(byte-addr bitpattern ==>)
	.if df newtoggle
	clr	r0	;make sure high byte is clear
	bisb	(s),r0	;load bit pattern into general register
	tst	(s)+	;don't need it any more
	bit	#1,(s)	;see if odd address
	beq	10$	;continue if not
	swab	r0	;else move bit pattern to high byte
	bic	#1,(s)	;make the address even
10$:	xor	r0,@(s)+ ;toggle the bits and clean up the stack
	.iff	;newtoggle
	mov	2(s),-(s) ;copy the byte to be toggled...
	movb	@(s),(s) ;...two steps so autodecrements works correctly
	mov	(s),-(rp) ;copy the existing byte to the return stack
	bic	2(s),(rp) ;clear any bitmask bits in existing byte
	bic	(s)+,(s) ;then do the same for the bitmask
;This takes care of the "non-exclusive" bits
	bis	(rp)+,(s) ;then set the remaining bitmask bits
	mov	2(s),-(s) ;set up return address
	movb	2(s),@(s) ;place the toggled byte into memory
	add	#6,s	;adjust stack pointer
	.endc	;newtoggle
	next
;Return contents of memory (addr ==> n)			; ***** @
	define	at,@
	mov	@(s),(s) ;(addr ==> n)
	next
;Return 8-bit contents of memory (addr ==> n)		; ***** C@
	define	cat,C@
	.if df newcat
	clr	-(rp)	;clear a space on return stack
	movb	@(s),(rp) ;get the desired byte
	mov	(rp)+,(s) ;and overwrite the address with it
	.iff
	movb	@(s),r1
	bic	#177400,r1
	mov	r1,(s)
	.endc	;newcat
	next
;Store n at addr (n addr ==>)				; ***** !
	define	store,!
	mov	2(s),@(s)
	add4	s
	next
;Store 8-bit quantity at addr (n addr ==>)		; ***** C!
	define	cstore,C!
	movb	2(s),@(s) ;same as <!> but only a byte is stored
	add4	s
	next
;
.PAGE
; ****************************************************************
;
;		PRE-COMPILED FORTH SECTION
;
; ****************************************************************
;
;
;
;  NOTE - A FEW OF THE FOLLOWING OPERATIONS HAVE BEEN
;  CONVERTED TO CODE FOR SPEED.  HOWEVER, THE WORD ORDER
;  IN THE DICTIONARY HAS NOT BEEN CHANGED.
;
;Set up high-level definition				; ***** :
	.immediate ;set precedence bit
	define	colon,:,docol
	.word	qexec	;error if already in compilation state
	.word	scsp	;store current stack pointer
	.word	curr,at,cont,store,create,rbrac,pscod ;set up for definition
docol::	mov	ip,-(rp) ;save current IP
	mov	w,ip	;muscle in with current CA
	next
;Terminate definition					; ***** ;
	.immediate ;set precedence bit
	define	semi,<;>,docol
	.word	qcsp,comp,semis,smudg,lbrac,semis
;Set up a constant definition				; ***** CONSTANT
	define	constant,CONSTANT,docol
	.word	create,smudg,comma,pscod
docon::	mov	(w),-(s)
	next
;Set up a variable definition				; ***** VARIABLE
	define	variable,VARIABLE,docol
	.word	constant,pscod
dovar::	mov	w,-(s)
	next
;Set up a new user variable (n ==> )			; ***** USER
	define	user,USER,docol
	.word	constant,pscod
douse::	mov	(w),-(s)
	add	u,(s)
	next
;
;  CONSTANTS
;
	define	zero,0,docon,0				; ***** 0
	define	one,1,docon,1				; ***** 1
	define	two,2,docon,2				; ***** 2
	define	three,3,docon,3				; ***** 3
	define	bl,BL,docon,32. ;blank			; ***** BL
	define	cl,C/L,docon,64. ;chars per line	; ***** C/L
;
; 'FIRST' AND 'LIMIT' MOVED TO USER AREA
;
	define	bbuf,B/BUF,docon,1024. ;bytes per block	; ***** B/BUF
	define	bscr,B/SCR,docon,1 ;blocks per screen	; ***** B/SCR
;
;Return address, given offset from origin		; ***** +ORIGIN
	define	porigin,+ORIGIN,docol
	.word	lit,origin,plus,semis
;
;  USER VARIABLES
;
	define	szero,S0,douse,6			; ***** S0
	define	rzero,R0,douse,8.			; ***** R0
	define	tib,TIB,douse,10. ;terminal input buffer; ***** TIB
	define	width,WIDTH,douse,12. ;max name length	; ***** WIDTH
	define	warn,WARNING,douse,14. ;warning mode	; ***** WARNING
	define	fence,FENCE,douse,16. ;limits FORGET	; ***** FENCE
	define	dp,DP,douse,18. ;dictionary pointer	; ***** DP
	define	vocl,VOC-LINK,douse,20.			; ***** VOC-LINK
	define	first,FIRST,douse,22. ;disk buffer	; ***** FIRST
	define	limit,LIMIT,douse,24. ;past disk buffers; ***** LIMIT
;Positions 26. and 28. are available for expansion
;They are initialized at cold start from the boot-up table
	.if df newtio ;set up user variables for LUNs in RSX
use.si=26.
use.so=28.
	define	inlun,INLUN,douse,use.si
	define	outlun,OUTLUN,douse,use.so
	.endc	;newtio
	define	blk,BLK,douse,30. ;current disk block	; ***** BLK
	define	in,IN,douse,32. ;offset in TIB		; ***** IN
	define	out,OUT,douse,34. ;offset in output line; ***** OUT
	define	scr,SCR,douse,36. ;current disk screen	; ***** SCR
	define	offset,OFFSET,douse,38. ;to next drive	; ***** OFFSET
	define	cont,CONTEXT,douse,40.			; ***** CONTEXT
	define	curr,CURRENT,douse,42.			; ***** CURRENT
	define	state,STATE,douse,44.			; ***** STATE
	define	base,BASE,douse,46.			; ***** BASE
	define	dpl,DPL,douse,48. ;decimal point offset	; ***** DPL
	define	fld,FLD,douse,50. ;output field width	; ***** FLD
	define	csp,CSP,douse,52. ;current stack pos.	; ***** CSP
	define	rnum,R#,douse,54. ;cursor position	; ***** R#
	define	hld,HLD,douse,56. ;last char in PAD	; ***** HLD
	define	use,USE,douse,58.			; ***** USE
	define	prev,PREV,douse,60.			; ***** PREV
;
; END OF USER AREA
;
	define	onep,1+ ;add 1 to n (n ==> n+1)		; ***** 1+
	inc	(s)
	next
;
	define	twop,2+ ;add 2 to n (n ==> n+2)		; ***** 2+
	add	#2,(s)
	next
;
	define	here,HERE,docol				; ***** HERE
	.word	dp,at,semis
;
	define	allot,ALLOT,docol			; ***** ALLOT
	.word	dp,pstore,semis
;
	define	comma,<,>,docol				; ***** ,
	.word	here,store,two,allot,semis
;
;  This system does not use 'C,'
;
	define	sub,-					; ***** -
	sub	(s)+,(s) ;subtract n2 from n1
	next
;
	define	equal,=					; ***** =
	cmp	2(s),(s)+
	beq	10$	;true if so
	clr	(s)	;else false
	br	20$
10$:	mov	#1,(s)	;return TRUE
20$:	next
;
	define	less,^/</				; ***** <
	cmp	2(s),(s)+
	blt	10$	;skip if true
	clr	(s)	;else false
	br	20$
10$:	mov	#1,(s)	;TRUE
20$:	next
;
	define	great,^/>/				; ***** >
	cmp	2(s),(s)+
	bgt	10$	;skip if true
	clr	(s)	;else false
	br	20$
10$:	mov	#1,(s)	;store TRUE
20$:	next
;
	define	rot,ROT					; ***** ROT
	mov	(s),r0	;shift positions
	mov	4(s),(s)
	mov	2(s),4(s)
	mov	r0,2(s)
	next
;
	define	space,SPACE,docol			; ***** SPACE
	.if df newspace
	.word	bl,emit,semis
	.iff
	.word	lit,32.,emit,semis
	.endc	;newspace
;
	define	ddup,-DUP				; ***** -DUP
	tst	(s)	;duplicate only if nonzero
	beq	10$
	mov	(s),-(s)
10$:	next
;
	define	traverse,TRAVERSE,docol			; ***** TRAVERSE
;(addr1 direction ==> addr2)
;Search in direction indicated (1=forwards,-1=backwards) for other end of
; Forth word for which one end is pointed to by addr1.
	.word	swap	;put starting address at top of stack
10$:	.word	over,plus ;add the direction indicator to a copy of addr1
	.word	lit,177,over,cat,less,zbranch,10$-. ;loop while 177 >= C
	.word	swap,drop,semis ;put end address 2nd then drop direction
;
	define	latest,LATEST,docol			; ***** LATEST
	.word	curr,at,at,semis
;
;  THE NEXT 4 OPERATORS CAN DEPEND ON COMPUTER WORD SIZE.
;  THEY CONVERT ADDRESSES WITHIN THE NAME FIELDS OF FORTH
;  DICTIONARY ENTRIES.
;Example header:
;NFA ==> |204 B| ;word BLAH, length 4
;        | L  A|
;        | H   | ;MSB of H is set (in original FIG, MSB of space was set)
;LFA ==> |01216| ;points back to NFA of previous word
;CFA ==> | PFA | ;for a primitive word, CFA always points to PFA
;PFA ==> | ... | ;in primitive, the machine language routine starts here
;
;Convert Parameter Field Address to Link Field Address
	define	lfa,LFA,docol				; ***** LFA
	.word	lit,4,sub,semis ;just point back 2 words
;Convert Parameter Field Address to Code Field Address
	define	cfa,CFA,docol				; ***** CFA
	.word	two,sub,semis ;one word back
;Convert Parameter Field Address to Name Field Address
	define	nfa,NFA,docol				; ***** NFA
	.if df newnfa
	.word	lit,5,sub,dup,cat ;does the word end on an odd byte?
	.word	lit,200,less,sub ;if so, adjust pointer back to word end
;notice that this only works with FIG standard of TRUE=1; change to + in F83!
	.word	lit,-1,traverse,semis ;travel to start of word
	.iff
	.word	lit,5,sub,lit,-1,traverse,semis
	.endc	;newnfa
;Convert Name Field Address to Parameter Field Address
	define	pfa,PFA,docol				; ***** PFA
	.word	one,traverse ;first move forward to char with MSB set...
	.if df newpfa
;if the word ends on an odd byte we must advance 6, otherwise 5...
	.word	lit,6,plus,lit,-2,and,semis ;so add 6 and clear LSB
	.iff
	.word	lit,5,plus,semis
	.endc	;newpfa
;
;  THE NEXT 7 OPERATIONS ARE USED BY THE COMPILER, FOR
;  COMPILE-TIME SYNTAX-ERROR CHECKS.
;
	define	scsp,!CSP,docol				; ***** !CSP
	.word	spat,csp,store,semis
;
	define	qerr,?ERROR,docol			; ***** ?ERROR
	.word	swap,zbranch,20$-.,error,branch,30$-.
20$:	.word	drop
30$:	.word	semis
;
	define	qcomp,?COMP,docol			; ***** ?COMP
	.word	state,at,zequ,lit,17.,qerr,semis
;
	define	qexec,?EXEC,docol			; ***** ?EXEC
	.word	state,at,lit,18.,qerr,semis
;
	define	qpair,?PAIRS,docol			; ***** ?PAIRS
	.word	sub,lit,19.,qerr,semis
;
	define	qcsp,?CSP,docol				; ***** ?CSP
	.word	spat,csp,at,sub,lit,20.,qerr,semis
;
	define	qload,?LOADING,docol			; ***** ?LOADING
	.word	blk,at,zequ,lit,22.,qerr,semis
;Compile following execution address			; ***** COMPILE
	define	comp,COMPILE,docol
	.word	qcomp,fromr,dup,twop,tor,at,comma,semis
;Stop compilation, enter execution state		; ***** [
	.immediate ;set precedence bit
	define	lbrac,[,docol
	.word	zero,state,store,semis
;Enter compilation state				; ***** ]
	define	rbrac,],docol
	.word	lit,300,state,store,semis
;Hide latest dictionary entry from searches		; ***** SMUDGE
	define	smudg,SMUDGE,docol
	.word	latest,lit,40,toggle,semis
;
	define	hex,HEX,docol ;set hexadecimal radix	; ***** HEX
	.word	lit,16.,base,store,semis
;
	define	decimal,DECIMAL,docol ;decimal radix	; ***** DECIMAL
	.word	lit,10.,base,store,semis
;
	define	octal,OCTAL,docol			; ***** OCTAL
	.word	lit,8.,base,store,semis
;
	define	pscod,<(;CODE)>,docol			; ***** (;CODE)
;Used only by compiler; compiled by ';CODE'.
	.word	fromr,latest,pfa,cfa,store,semis
;
;
;  ***** THE DEFINITION OF ';CODE' WAS MOVED TO THE END OF
;  THE DICTIONARY, BECAUSE IT IS NOT PURE CODE (IT IS PATCHED
;  WHEN A FORTH ASSEMBLER IS LOADED).
;
	define	builds,^/<BUILDS/,docol			; ***** <BUILDS
;create new data type with code routine in higher-level forth.
	.word	zero,constant,semis
;
	define	does,DOES>,docol			; ***** DOES>
	.word	fromr,latest,pfa,store,pscod
dodoe::	mov	ip,-(rp)
	mov	(w)+,ip
	mov	w,-(s)
	next
;
	define	count,COUNT,docol			; ***** COUNT
;convert string to the format used by 'type'.
	.word	dup,onep,swap,cat,semis
;
	define	type,TYPE,docol				; ***** TYPE
	.word	ddup,zbranch,20$-.,over,plus,swap,xdo
10$:	.word	i,cat,emit,xloop,10$-.,branch,30$-.
20$:	.word	drop
30$:	.word	semis
;
	define	ecells,=CELLS,docol			; ***** =CELLS
;NOTE - we need this, to force even addresses.
	.word	dup,one,and,plus,semis
;
	define	dtrailing,-TRAILING,docol		; ***** -TRAILING
	.word	dup,zero,xdo
60$:	.word	over,over,plus,one,sub,cat
	.word	bl,sub,zbranch,70$-.,leave,branch,80$-.
70$:	.word	one,sub
80$:	.word	xloop,60$-.,semis
;
	define	pdotq,(."),docol			; ***** (.")
;Used only by compiler.  compiled by '."'
	.word	r,count,dup,onep,ecells
	.word	fromr,plus,tor,type,semis
;
	.immediate ;set precedence bit
	define	dotq,.",docol				; ***** ."
;Type ASCII message.
	.word	lit,34.,state,at,zbranch,60$-.
	.word	comp,pdotq,word,here,cat,onep,ecells
	.word	allot,branch,70$-.
60$:	.word	word,here,count,type
70$:	.word	semis
;
	define	qalign,?ALIGN,docol			; ***** ?ALIGN
;(==>) Affects DP only
;word-align the current dict entry by allocating another space if necessary
	.word	here,one,and,allot,semis
;
	define	expect,EXPECT,docol			; ***** EXPECT
;read n characters to memory (and terminate with nulls).  
; ( addr n ==>).
	.word	over,plus,over,xdo ;loop from addr to addr+n
10$:	.word	key,dup,lit,14.,porigin,at,equal,zbranch,20$-. ;backspace?
	.word	drop,lit,8.,over,i,equal,dup,fromr
	.word	two,sub,plus,tor,sub,branch,30$-.
20$:	.word	dup,lit,13.,equal,zbranch,40$-. ;terminate on CR
	.word	leave,drop,bl,zero,branch,50$-.
40$:	.word	dup
50$:	.word	i,cstore,zero,i,onep,cstore,zero,i,twop,cstore
;  note difference for stand-alone, below
	.ifdf	alone
30$:	.word	emit,xloop,10$-.,drop,semis
	.iff
30$:	.word	drop,xloop,10$-.,drop,semis   
	.endc	;alone
;
	define	query,QUERY,docol			; ***** QUERY
	.word	tib,at,lit,80.,expect,zero,in,store,semis
;
	.immediate ;set precedence bit
	define	null,null,docol				; ***** the null
;The null operation (ascii 0) stops interpretation/compilation
; at end of a terminal input line, or a disk screen.  all disk
; buffers must terminate with nulls, and 'expect' places nulls
; after each terminal input line.
;This special header is created automagically by the DEFINE macro. 
	.word	blk,at
	.word	zbranch,20$-.,one,blk,pstore,zero,in,store
	.word	blk,at,bscr,mod,zequ,zbranch,10$-.,qexec,fromr,drop
10$:	.word	branch,40$-.
20$:	.word	fromr,drop
40$:	.word	semis
;
	define	fill,FILL,docol				; ***** FILL
	.word	swap,tor,over,cstore,dup,onep,fromr
	.word	one,sub,cmove,semis
;
	define	erase,ERASE,docol			; ***** ERASE
	.word	zero,fill,semis
;
	define	blanks,BLANKS,docol			; ***** BLANKS
	.word	bl,fill,semis
;
	define	hold,HOLD,docol				; ***** HOLD
	.word	lit,-1,hld,pstore,hld,at,cstore,semis
;
	define	pad,PAD,docol				; ***** PAD
	.word	here,lit,104,plus,semis
;
	define	word,WORD,docol				; ***** WORD
	.word	blk,at,zbranch,10$-.,blk,at,block,branch,20$-.
10$:	.word	tib,at
20$:	.word	in,at,plus,swap,enclose,here,lit,34.,blanks,in
	.word	pstore,over,sub,tor,r,here,cstore,plus
	.word	here,onep,fromr,cmove,semis
;
	define	pnumber,(NUMBER),docol			; ***** (NUMBER)
30$:	.word	onep,dup,tor,cat,base,at,digit
	.word	zbranch,40$-.,swap,base,at,ustar,drop
	.word	rot,base,at,ustar,dplus
	.word	dpl,at,onep,zbranch,50$-.,one,dpl,pstore
50$:	.word	fromr,branch,30$-.
40$:	.word	fromr,semis
;
	define	number,NUMBER,docol			; ***** NUMBER
	.word	zero,zero,rot,dup,onep,cat,lit,55,equal
	.word	dup,tor,plus,lit,-1
60$:	.word	dpl,store,pnumber,dup,cat,bl,sub
	.word	zbranch,70$-.,dup,cat,lit,56,sub
	.word	zero,qerr,zero,branch,60$-.
70$:	.word	drop,fromr,zbranch,80$-.,dminus
80$:	.word	semis
;
	define	dfind,-FIND,docol			; ***** -FIND
	.word	bl,word,here,count,upper,here,cont,at,at,pfind
	.word	dup,zequ,zbranch,30$-.,drop,here,latest,pfind
30$:	.word	semis
;
	define	upper,UPPER,docol			; ***** UPPER
;Sets strings to upper case - to allow
; lower as well as upper case from terminal.
	.word	over,plus,swap,xdo
20$:	.word	i,cat,lit,140,great,i,cat,lit,173,less
	.word	and,zbranch,10$-.,i,lit,40,toggle
10$:	.word	xloop,20$-.,semis
;
	define	pabort,(ABORT),docol			; ***** (ABORT)
	.word	abort,semis
;
	define	error,ERROR,docol			; ***** ERROR
	.word	warn,at,zless,zbranch,40$-.,pabort
40$:	.word	here,count,type
	.pdotq	< ? >
	.word	mess,spstore,in,at,blk,at,quit,semis
;
	define	iddot,ID.,docol				; ***** ID.
;displays the name of a dictionary entry, given its NFA
;modified to show final character normally in 8-bit environment
;also got rid of unnecessary buffer initialization (filling with underscores)
;2/18/96 jlc
	.if df newiddot
	.word	dup	;just duplicate the NFA
	.word	pfa,lfa,over,sub,pad,swap,cmove ;copy word to string buffer
	.word	pad,count,lit,37,and,one,sub,over,over,type ;display the word
	.word	plus,cat,lit,177,and,emit,space,semis ;trim msb on final letter
	.iff	;original FIG version
	.word	pad,lit,40,lit,137,fill,dup
	.word	pfa,lfa,over,sub,pad,swap,cmove
	.word	pad,count,lit,37,and,type,space,semis
	.endc	;newiddot
;
	define	create,CREATE,docol			; ***** CREATE
;Define a new primitive Forth word, creating the header.
;Issue a warning message if it already exists, but do it anyway.
	.word	dfind,zbranch,20$-.,drop,nfa,iddot ;show the existing name
	.word	lit,4,mess,space ;tell user it was already in the dictionary
;Remember that the new word has already been stored at current end of dict
20$:	.word	here,dup,cat,width,at,min ;truncate if exceeds max width
	.word	onep,allot ;allocate 1 more than the width, for the count byte
	.if df newcreate
	.word	dup,lit,240,toggle ;smudge the word
	.word	here,one,sub,lit,200,toggle ;mark final char
	.word	qalign ;word align
	.iff
	.word	qalign ;align on even byte
	.word	dup,lit,240,toggle ;smudge the word
	.word	here,one,sub,lit,200,toggle ;set high bit on final byte
	.endc	;newcreate
	.word	latest,comma,curr,at,store ;make this the current word
	.word	here,twop,comma,semis ;point forward to the PFA
;
	.immediate ;set precedence bit
	define	bcompile,[COMPILE],docol		; ***** [COMPILE]
	.word	dfind,zequ,zero,qerr,drop,cfa,comma,semis
;
	.immediate ;set precedence bit
	define	literal,LITERAL,docol			; ***** LITERAL
	.word	state,at,zbranch,60$-.,comp,lit,comma
60$:	.word	semis
;
	.immediate ;set precedence bit
	define	dliteral,DLITERAL,docol			; ***** DLITERAL
	.word	state,at,zbranch,50$-.,swap,literal,literal
50$:	.word	semis
;
	define	uless,U<,docol				; ***** U<
;Unsigned less-than, needed for '?stack'
; : u< >r 0 r> 0 dminus d+ swap drop 0< ;
	.word	tor,zero,fromr,zero,dminus,dplus
	.word	swap,drop,zless,semis
;
	define	qstack,?STACK,docol			; ***** ?STACK
;Error check.
	.word	szero,at,two,sub,spat,uless,one,qerr
	.word	spat,here,lit,200,plus,uless,two,qerr
	.word	semis
;
	define	interpret,INTERPRET,docol		; ***** INTERPRET
40$:	.word	dfind
	.word	zbranch,80$-.,state,at,less
	.word	zbranch,50$-.,cfa,comma,branch,60$-.
50$:	.word	cfa,execute
60$:	.word	qstack,branch,70$-.
80$:	.word	here,number,dpl,at,onep,zbranch,84$-.
	.word	dliteral,branch,85$-.
84$:	.word	drop,literal
85$:	.word	qstack
70$:	.word	branch,40$-.
;
	define	immediate,IMMEDIATE,docol		; ***** IMMEDIATE
	.word	latest,lit,100,toggle,semis
;
	define	vocabulary,VOCABULARY,docol		; ***** VOCABULARY
	.word	builds,lit,120201,comma,curr,at,cfa,comma
	.word	here,vocl,at,comma,vocl,store,does
dovoc::	.word	twop,cont,store,semis
;
;
;  ***** THE DEFINITION OF 'FORTH' WAS MOVED TO NEAR THE END OF THE
;  DICTIONARY, BECAUSE IT IS NOT PURE CODE.
;
;
	define	definitions,DEFINITIONS,docol		; ***** DEFINITIONS
	.word	cont,at,curr,store,semis
;
	.immediate ;set precedence bit
	define	paren,(,docol				; ***** (
	.word	lit,'),word,semis ;just skip to close parenthesis
;
	define	quit,QUIT,docol				; ***** QUIT
	.word	zero,blk,store,lbrac
10$:	.word	rpstore,cr,query,interpret,state,at
	.word	zequ,zbranch,20$-.
	.pdotq	< OK>
20$:	.word	branch,10$-.
;
	define	abort,ABORT,docol			; ***** ABORT
	.word	spstore,decimal,space,cr
	.pdotq	<FIG-FORTH  V 1.3 >
	.word	forth,definitions,quit
;
;  COLD AND WARM STARTS
;
	define	cold,COLD				; ***** COLD
cent::	.enable	lsb		; cold start entry point
	mov	origin+12.,forth+6 ; set 'forth' vocabulary from startup table
	mov	origin+16.,u	; initialize user pointer
;NOTE - for smaller stand-alone boot, initialize areas in
; high memory which must be initialized.
;Clear disk buffers on first time through
	mov	origin+34.,r0	; 'first' - beginning of disk buffers
	mov	origin+36.,r1	; 'limit' - just beyond disk buffers
10$:	clr	(r0)+
	cmp	r0,r1
	blt	10$
;Now initialize 'out', 'offset', 'use' and 'prev'
	clr	34.(u)		; clear 'out'
	clr	38.(u)		; clear 'offset'
	mov	origin+34.,58.(u) ; to 'use'
	mov	origin+34.,60.(u) ; to 'prev'
;End of special high-memory initialize
	mov	#24.,r1		; on cold start, move 24. bytes
	br	12$
went::				; warm start entry point
	mov	#10.,r1		; on warm start, move ten bytes
12$:	mov	#origin+18.,r5	; start moving from here
	mov	origin+16.,r0	; move to the user area
	add	#6,r0		;   plus 6
	add	r5,r1		; compute loop stop address
20$:	mov	(r5)+,(r0)+
	cmp	r5,r1
	blt	20$
	mov	origin+20.,rp	; initialize the return-stack pointer
;Now set forth's instruction counter, and go
	mov	#go,ip	; start execution with 'abort'
	next
;NOTE - normally the above instruction would be 'mov #abort+2,ip'.
;It has been changed here to allow user to patch a different
;start-up. But the system won't work until some of the work 
;of 'abort' has been done, so that work is repeated. The user
;can patch over the 'abort' and the zeros.
;
go::	.word	spstore,decimal,forth,definitions,abort,0,0,0
	.dsable	lsb	;end of local symbol block
;
	define	stod,S->D				; ***** S->D
	clr	-(s)	;sign extend with zeroes
	tst	2(s)	;but if negative,
	bpl	10$	;...
	dec	(s)	;change the zeros to ones
10$:	next
;
;  NOTE - THIS SYSTEM DOESN'T NEED THE OPERATIONS '+-' AND 'D+-',
;    BECAUSE 'M*' AND 'M/' ARE DEFINED IN CODE.
;
	.if df newabs
	define	abs,ABS					; ***** ABS
	tst	(s)	;already positive?
	bpl	10$	;done if so
	neg	(s)	;else negate it to make it so
10$:	next
	.iff	;old version is high level
	define	abs,ABS,docol
	.word	dup,zless,zbranch,10$-.,minus
10$:	.word	semis
	.endc	;newabs
;
	define	dabs,DABS,docol				; ***** DABS
	.word	dup,zless,zbranch,10$-.,dminus
10$:	.word	semis
;
	.if df newmin
	define	min,MIN					; ***** MIN
	mov	(s)+,r0	;copy top word into temp register
	cmp	r0,(s)	;see if it's less than what's on stack
	bge	10$	;if not, we're done
	mov	r0,(s)	;return the lower value
10$:	next
	.iff	;old MIN is high level
	define	min,MIN,docol
	.word	over,over,great,zbranch,10$-.,swap
10$:	.word	drop,semis
	.endc	;newmin
;
	.if df newmax
	define	max,MAX					; ***** MAX
	mov	(s)+,r0	;copy top word into temp register
	cmp	r0,(s)	;see if it's more than what's on stack
	ble	10$	;if not, we're done
	mov	r0,(s)	;return the higher value
10$:	next
	.iff	;old MAX is high level
	define	max,MAX,docol
	.word	over,over,less,zbranch,10$-.,swap
10$:	.word	drop,semis
	.endc	;newmax
;
	define	mstar,M*				; ***** M*
	.if df eis ;hardware multiply/divide
	mov	(s)+,r0 ;get multiplier
	mul	(s),r0	;times multiplicand
	mov	r1,(s)	;store LSBs
	mov	r0,-(s)	;then MSBs
	next
	.iff	;no hardware multiply, let's shift some bits
	mov	2(s),-(rp) ;save sign on return stack
	bpl	10$	;skip if already positive
	neg	2(s)	;else get abs(n1)
10$:	tst	(s)	;is this arg positive?
	bpl	20$	;skip ahead if so
	neg	(rp)	;else adjust saved sign
	neg	(s)	;get abs(n2)
20$:	call	umult	;use unsigned multiplication routine
	tst	(rp)+	;get sign back
	bpl	30$	;finish if positive
	com	(s)	;else negate the double-integer
	com	2(s)	;first ones complement
	add	#1,2(s)	;then twos complement
	adc	(s)	;...
	next
	.endc	;eis
;
	define	mslash,M/				; ***** M/
	.if df eis ;hardware multiply/divide
	mov	2(s),r0 ;get MSBs of dividend
	mov	4(s),r1	;LSBs
	div	(s)+,r0 ;divide...
	mov	r1,2(s)	;now store the remainder...
	mov	r0,(s)	;and the quotient
	next
	.iff	;no EIS, so work a little harder
	mov	2(s),-(rp) ;save sign
	bne	10$	;continue if nonzero
	inc	(rp)	;must be nonzero for sign trick to work
10$:	mov	(rp),-(rp) ;duplicate sign indicator
	bpl	20$	;continue if nonnegative
	com	2(s)	;else get abs(d)
	com	4(s)	;...
	add	#1,4(s)	;2s complement
	adc	2(s)	;...
20$:	tst	(s)	;check divisor
	bpl	30$	;continue if positive
	neg	(rp)	;else change saved sign accordingly
	neg	(s)	;also get abs(n)
30$:	call	udiv	;use unsigned division routine
	tst	(rp)+	;check sign and toss it
	bpl	40$	;continue if nonnegative
	neg	(s)	;else change it
40$:	tst	(rp)+	;negative dividend?
	bpl	50$	;continue if not
	neg	2(s)	;else adjust remainder
50$:	next
	.endc	;eis
;
	define	star,*,docol				; ***** *
	.word	mstar,drop,semis
;
	define	slashmod,/MOD,docol			; ***** /MOD
	.word	tor,stod,fromr,mslash,semis
;
	define	slash,/,docol				; ***** /
	.word	slashmod,swap,drop,semis
;
	define	mod,MOD,docol				; ***** MOD
	.word	slashmod,drop,semis
;
	define	ssmod,*/MOD,docol			; ***** */MOD
	.word	tor,mstar,fromr,mslash,semis
;
	define	sslash,*/,docol				; ***** */
	.word	ssmod,swap,drop,semis
;
	define	msmod,M/MOD,docol			; ***** M/MOD
	.word	tor,zero,r,uslash,fromr
	.word	swap,tor,uslash,fromr,semis
.PAGE
; ****************************************************************
;
;	DISK I/O  (SECTION COMMON TO ALL OPERATING SYSTEMS)
;	NOTE THAT EACH OPERATING SYSTEM DEFINED 'R/W' - READ
;	OR WRITE A 1024-BYTE RANDOM-ACCESS BLOCK.
;
; ****************************************************************
;
;
; 'USE' AND 'PREV' MOVED TO USER AREA
;
	define	pbuf,+BUF,docol
	.word	bbuf,lit,4,plus,plus,dup,limit,at,equal
	.word	zbranch,10$-.,drop,first,at
10$:	.word	dup,prev,at,sub,semis
;
	HEAD	206,UPDATE,240,UPDAT,DOCOL		; ***** UPDATE
	.WORD	PREV,AT,AT,LIT,100000,OR,PREV
	.WORD	AT,STORE,SEMIS
;
	HEAD	215,EMPTY-BUFFERS,323,MTBUF,DOCOL	; ***** EMPTY-BUFFERS
	.WORD	FIRST,AT,LIMIT,AT,OVER,SUB,ERASE,SEMIS
;
	HEAD	205,FLUSH,310,FLUSH,DOCOL		; ***** FLUSH
;  SOME SYSTEMS DEFINE THIS IN THE EDITOR, NOT HERE.
	.WORD	LIMIT,AT,FIRST,AT,XDO
XXTA:	.WORD	I,AT,ZLESS,ZBRANCH,XXT7-.,I,TWOP,I,AT
	.WORD	LIT,77777,AND,ZERO,RW
XXT7:	.WORD	BBUF,LIT,4,PLUS,XPLOOP,XXTA-.,MTBUF,SEMIS
;
	HEAD	203,DR0,260,DRZER,DOCOL			; ***** DR0
;  SELECT DRIVE #0 - NOT USED WITH RT11 OR RSX11
	.WORD	ZERO,OFFSET,STORE,SEMIS
;
	HEAD	203,DR1,261,DRONE,DOCOL			; ***** DR1
; SELECT DRIVE #1 - NOT USED IN RSX11 OR RT11  
	.WORD	LIT,240.,OFFSET,STORE,SEMIS
;
	HEAD	206,BUFFER,240,BUFFE,DOCOL		; ***** BUFFER
	.WORD	USE,AT,DUP,TOR
XXT2:	.WORD	PBUF,ZBRANCH,XXT2-.,USE,STORE
	.WORD	R,AT,ZLESS,ZBRANCH,XXT3-.
	.WORD	R,TWOP,R,AT,LIT,77777,AND
	.WORD	ZERO,RW
XXT3:	.WORD	R,STORE,R,PREV,STORE,FROMR,TWOP,SEMIS
;
	HEAD	205,BLOCK,313,BLOCK,DOCOL		; ***** BLOCK
; CHANGED TO MASK OFF THE UPDATE BIT WHEN COMPARING
	.WORD	OFFSET,AT,PLUS,TOR
	.WORD	PREV,AT,DUP,AT,LIT,077777,AND,R,SUB,ZBRANCH,XXT4-.
XXT5:	.WORD	PBUF,ZEQU,ZBRANCH,XXT6-.
	.WORD	DROP,R,BUFFE
	.WORD	DUP,R,ONE,RW,TWO,SUB
XXT6:	.WORD	DUP,AT,LIT,077777,AND,R,SUB,ZEQU
	.WORD	ZBRANCH,XXT5-.
	.WORD	DUP,PREV,STORE
XXT4:	.WORD	FROMR,DROP,TWOP,SEMIS
;
	HEAD	206,(LINE),240,PLINE,DOCOL		; ***** (LINE)
	.WORD	TOR,CL,BBUF,SSMOD,FROMR,BSCR
	.WORD	STAR,PLUS,BLOCK,PLUS,CL,SEMIS
;
	HEAD	205,.LINE,305,DLINE,DOCOL		; ***** .LINE
	.WORD	PLINE,DTRAILING,TYPE,SEMIS
;
	HEAD	207,MESSAGE,305,MESS,DOCOL		; ***** MESSAGE
	.WORD	WARN,AT,ZBRANCH,XXW5-.,DDUP,ZBRANCH,XXW3-.,LIT,4
	.WORD	OFFSET,AT,BSCR,SLASH,SUB,DLINE
XXW3:	.WORD	BRANCH,XXW4-.
XXW5:	.pdotq	<MSG # >
	.WORD	DOT
XXW4:	.WORD	SEMIS
;
	HEAD	204,LOAD,240,LOAD,DOCOL			; ***** LOAD
	.WORD	BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
	.WORD	BSCR,STAR,BLK,STORE,INTERPRET,FROMR,IN,STORE
	.WORD	FROMR,BLK,STORE,SEMIS
;
	HEAD	303,-->,276,ARROW,DOCOL			; ***** -->
	.WORD	QLOAD,ZERO,IN,STORE,BSCR,BLK,AT,OVER
	.WORD	MOD,SUB,BLK,PSTORE,SEMIS
;
;  NOTE - THE INSTALLATION-DEPENDENT I/O IS AT THE END
;  OF THE DICTIONARY - JUST BELOW 'TASK'.  'XI/O' IS THE
;  PRIMITIVE READ OR WRITE OF A 512-BYTE BLOCK.
;
.PAGE
; ****************************************************************
;
;	MISCELLANEOUS HIGHER LEVEL
;
; ****************************************************************
;
	.immediate					; ***** '
	define	tick,',docol
	.word	dfind,zequ,zero,qerr,drop,literal,semis
;
	HEAD	206,FORGET,240,FORGE,DOCOL		; ***** FORGET
	.WORD	CURR,AT,CONT,AT,SUB,LIT,30,QERR,TICK,DUP
	.WORD	FENCE,AT,LESS,LIT,25,QERR
	.WORD	DUP,NFA,DP,STORE,LFA,AT,CONT,AT
	.WORD	STORE,SEMIS
;
	HEAD	204,BACK,240,BACK,DOCOL			; ***** BACK
	.WORD	HERE,SUB,COMMA,SEMIS
;
	HEAD	305,BEGIN,316,BEGIN,DOCOL		; ***** BEGIN
	.WORD	QCOMP,HERE,ONE,SEMIS
;
	HEAD	305,ENDIF,306,ENDIF,DOCOL		; ***** ENDIF
	.WORD	QCOMP,TWO,QPAIR,HERE,OVER,SUB,SWAP,STORE,SEMIS
;
	HEAD	304,THEN,240,THEN,DOCOL			; ***** THEN
	.WORD	ENDIF,SEMIS
;
	HEAD	302,DO,240,DO,DOCOL			; ***** DO
	.WORD	COMP,XDO,HERE,LIT,3,SEMIS
;
	HEAD	304,LOOP,240,LOOP,DOCOL			; ***** LOOP
	.WORD	LIT,3,QPAIR,COMP,XLOOP,BACK,SEMIS
;
	HEAD	305,+LOOP,320,PLOOP,DOCOL		; ***** +LOOP
	.WORD	LIT,3,QPAIR,COMP,XPLOOP,BACK,SEMIS
;
	HEAD	305,UNTIL,314,UNTIL,DOCOL		; ***** UNTIL
	.WORD	ONE,QPAIR,COMP,ZBRANCH,BACK,SEMIS
;
	HEAD	303,END,304,END,DOCOL			; ***** END
	.WORD	UNTIL,SEMIS
;
	HEAD	305,AGAIN,316,AGAIN,DOCOL		; ***** AGAIN
	.WORD	ONE,QPAIR,COMP,BRANCH,BACK,SEMIS
;
	HEAD	306,REPEAT,240,REPEAT,DOCOL		; ***** REPEAT
	.WORD	TOR,TOR,AGAIN,FROMR,FROMR,TWO,SUB,ENDIF,SEMIS
;
	HEAD	302,IF,240,IF,DOCOL			; ***** IF
	.WORD	COMP,ZBRANCH,HERE,ZERO,COMMA,TWO,SEMIS
;
	HEAD	304,ELSE,240,ELSE,DOCOL			; ***** ELSE
	.WORD	TWO,QPAIR,COMP,BRANCH,HERE,ZERO,COMMA
	.WORD	SWAP,TWO,ENDIF,TWO,SEMIS
;
	HEAD	305,WHILE,305,WHILE,DOCOL		; ***** WHILE
	.WORD	IF,TWOP,SEMIS
;
	HEAD	206,SPACES,240,SPACS,DOCOL		; ***** SPACES
	.WORD	ZERO,MAX,DDUP,ZBRANCH,XXR4-.,ZERO,XDO
XXRA:	.WORD	SPACE,XLOOP,XXRA-.
XXR4:	.WORD	SEMIS
;
	HEAD	202,^/<#/,240,BDIGS,DOCOL		; ***** <#
	.WORD	PAD,HLD,STORE,SEMIS
;
	HEAD	202,#>,240,EDIGS,DOCOL			; ***** #>
	.WORD	DROP,DROP,HLD,AT,PAD,OVER,SUB,SEMIS
;
	HEAD	204,SIGN,240,SIGN,DOCOL			; ***** SIGN
	.WORD	ROT,ZLESS,ZBRANCH,XXR1-.,LIT,55,HOLD
XXR1:	.WORD	SEMIS
;
	HEAD	201,#,243,DIG,DOCOL			; ***** #
	.WORD	BASE,AT,MSMOD,ROT,LIT,11,OVER,LESS
	.WORD	ZBRANCH,XXR2-.,LIT,7,PLUS
XXR2:	.WORD	LIT,60,PLUS,HOLD,SEMIS
;
	HEAD	202,#S,240,DIGS,DOCOL			; ***** #S
XXR3:	.WORD	DIG,OVER,OVER,OR,ZEQU,ZBRANCH,XXR3-.,SEMIS
;
	HEAD	203,D.R,322,DDOTR,DOCOL			; ***** D.R
	.WORD	TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN,EDIGS
	.WORD	FROMR,OVER,SUB,SPACS,TYPE,SEMIS
;
	HEAD	202,.R,240,DOTR,DOCOL			; ***** .R
	.WORD	TOR,STOD,FROMR,DDOTR,SEMIS
;
	HEAD	202,D.,240,DDOT,DOCOL			; ***** D.
	.WORD	ZERO,DDOTR,SPACE,SEMIS
;
	HEAD	201,.,256,DOT,DOCOL			; ***** .
	.WORD	STOD,DDOT,SEMIS
;
	HEAD	201,?,277,QUEST,DOCOL			; ***** ?
	.WORD	AT,DOT,SEMIS
;
	HEAD	202,U.,240,UDOT,DOCOL			; ***** U.
	.WORD	ZERO,DDOT,SEMIS
;
;  UTILITY SECTION.
;
	HEAD	204,LIST,240,LIST,DOCOL			; ***** LIST
; ( N---.  LIST GIVEN SCREEN.)
	.WORD	DECIMAL,CR,DUP,SCR,STORE
	.pdotq	<SCR # >
	.WORD	DOT,LIT,20,ZERO,XDO
XXZ1:	.WORD	CR,I,THREE,DOTR,SPACE
	.WORD	I,SCR,AT,DLINE,XLOOP,XXZ1-.,CR,SEMIS
;
	HEAD	205,INDEX,330,INDEX,DOCOL		; ***** INDEX
;  LIST FIRST LINE OF A RANGE OF DISK SCREENS.
	.WORD	CR,ONEP,SWAP,XDO
XXZ2:	.WORD	CR,I,THREE,DOTR,SPACE,ZERO,I,DLINE
	.WORD	QTERMINAL,ZBRANCH,XXZ3-.,LEAVE
XXZ3:	.WORD	XLOOP,XXZ2-.,SEMIS
;
	HEAD	205,TRIAD,304,TRIAD,DOCOL		; ***** TRIAD
;  LIST DISK SCREENS THREE PER PAGE.
	.WORD	LIT,14,EMIT		; FORM FEED
	.WORD	THREE,SLASH,THREE,STAR,THREE
	.WORD	OVER,PLUS,SWAP,XDO
XXZ4:	.WORD	CR,I,LIST,XLOOP,XXZ4-.,CR,LIT,17,MESS,CR,SEMIS
;
	define	vlist,VLIST,docol			; ***** VLIST
	.word	lit,200,out,store	;init pointer past end of line
	.word	cont,at,at		;get string pointed to by CONTEXT
10$:	.word	out,at,lit,100,great,zbranch,20$-. ;start new line if pos>64.
	.word	cr,zero,out,store	;else CRLF and zero output pointer
20$:	.word	dup,iddot,space,space,pfa,lfa,at ;display and point to next
	.word	dup,zequ,qterminal,or,zbranch,10$-.,drop,semis ;loop till done
		;quit if keyhit or end of dict (null found).
;
	.IFDF	LINKS
	HEAD	205,VLINK,313,XVLINK,DOCON		; ***** VLINK
;  THIS IS ONLY USED FOR LINKAGE FROM FORTH TO SUBROUTINES
;  IN OTHER LANGUAGES.  SEE USER'S GUIDE FOR DOCUMENTATION.
	.WORD	VLINK
	.ENDC
;
.PAGE
; ****************************************************************
;
; INSTALLATION-DEPENDENT SECTION (TERMINAL AND DISK I/O, AND TRAPS)
;
; ****************************************************************
;
;
; ***************
;
; RSX-11M TERMINAL I/O
;
; ***************
;
	.if df rsx11
	.even
;NOTE - FOR RSX-11 ON HEAVILY LOADED MACHINES, IT IS BETTER
;FOR 'KEY' TO READ A WHOLE LINE AT A TIME, AND UNPACK IT.
;ALSO, 'KEY' SHOULD EMIT A LINE FEED WHEN A CARRIAGE RETURN
;HAS BEEN READ.
;
pemit:	jsr	r1,iterm ;initialize RSX if we have to
;Increment 'OUT', unless a control character being output.
	cmp	(s),#32. ;test for control character
	blt	10$	;don't inc output count if less than ' '
	inc	34.(u)	;increment 'OUT' user variable
10$:	jsr	r1,xcout ;output a character
	next
;
pkey:	jsr	r1,iterm ;initialize RSX?
	tst	interm	;zero means read new line
	bne	xchar	;otherwise, next char from last line input
xline:	mov	#xbuff,interm ;read new line
	.if ndf newtio
	qiow$c	io.rvb,4,4,,iostat,,<xbuff,80.>
	.iff
	qiow$s	#io.rvb,use.si(u),#4,,#iostat,,<#xbuff,#80.>
	.endc
	add	#xbuff,iostat+2	;terminate line with CR
	movb	#13.,@iostat+2 ;...
xchar:	tst	-(s)	;decrement stack pointer
	movb	@interm,(s) ;for this byte instruction
	inc	interm
	bic	#177600,(s)
	cmp	(s),#13. ;if CR is being sent,
	bne	10$
	clr	interm	;then read new line next time.
	mov	#10.,-(s) ;and also emit a line feed
	jsr	r1,xcout
10$:	next
;
pqter:	jsr	r1,iterm ;initialize RSX if we haven't already
	mov	qflag,-(s) ;get unsolicited character if any
	clr	qflag	;empty it until next keyhit
	next
;Unsolicited character AST
ast1:	mov	(rp)+,qflag ;set up for next '?TERMINAL'; 
			;note that 'RP' is system stack.
	cmp	qflag,#3 ;test for ^C
	bne	10$
	mov 	#go,ip
10$:	astx$s
;
;
pcr:	jsr	r1,iterm ;initialize RSX I/O if necessary
	mov	#13.,-(s) ;send CR
	jsr	r1,xcout
	mov	#10.,-(s) ;then LF
	jsr	r1,xcout
	next
;
xcout:	mov	(s)+,iochr ;output a single character
	.if ndf newtio
	qiow$c	io.wvb!tf.wal,4,4,,iostat,,<iochr,1>
	.iff
	qiow$s	#<io.wvb!tf.wal>,use.so(u),#4,,#iostat,,<#iochr,#1>
	.endc	;newtio
	rts	r1
;
iterm:	;Initialize RSX if first time through
	.enable lsb	;necessary when using $C directives
	.if ndf newtio ;3 words where two will suffice
	cmp	interm,#-1 ;first time terminal I/O?
	bne	10$	;return if not
	.iff
	tst	interm	;cheaper test, but...
	bpl	10$	;depends on xbuff being located below 100000!
	.endc	;newtio
	.if df cmdline ;fetch command line from operating system
	dir$	#xbuff-2 ;query RSX for the command line
	movb	@#$dsw,r0 ;get number of chars, or error code
	bmi	4$	;skip if error
	movb	#13.,xbuff(r0) ;store a CR past the command
	mov	#xbuff,interm ;point to start of received line
	br	6$	;don't now clear INTERM
	.endc	;cmdline
4$:	clr	interm	;clear it for next time we check
6$:	.iif ndf newtio, alun$c 4,TI,0 ;assign input LUN
;done with TKB in new version
	.if df debug
	 .if ndf newtio
	  qiow$c io.att,4,4 ;simple attach when debugging
	 .iff ;newtio
	  ;don't attach at all
	 .endc ;newtio
	.iff ;debug
	 .if ndf newtio
	  qiow$c io.ata,4,,,,,<ast1> ;attach - unsolicited i/o
	 .iff ;newtio
	  qiow$s #io.ata,use.si(u),,,,,<#ast1>
	 .endc	;newtio
	.endc	;debug
	svtk$s	#trapv,#6 ;set up for traps
10$:	rts	r1
	.dsable lsb
;
interm:	.word	-1		;flag for first time terminal I/O.
;DO NOT REINITIALIZE 'INTERM' AT COLD START, LEST ASSIGNMENT DONE TWICE.
iochr:	.word	0	;temporary area for 'KEY' and 'EMIT'
qflag:	.word	0	;for '?TERMINAL'
	.iif df cmdline, .word 24577 ;GMCR$ directive code preceding XBUFF
xbuff:	.blkb	82.	;terminal buffer for RSX line I/O
;
;
;
	define	bye,BYE					; ***** BYE (log off)
	close$	#fdbio	;close disk I/O
	exit$s
;
;
; ***************
;
; RSX11-M DISK I/O
;
; ***************
;
	HEAD	204,XI/O,240,XIO			; ***** XI/O (RSX)
;  PHYSICAL READ-WRITE
;  ADDRESS  BLOCK# FLAG ==> REPORT.  READS OR WRITES A 512-BYTE BLOCK.
;  FLAG 1=READ, 0=WRITE.  REPORT '0'=GOOD I/O, '1'=I/O ERROR.
;  IF REPORT IS '1', THEN NEXT ON STACK IS '1'=OPEN ERROR,
;  '2'=READ ERROR, '3'=WRITE ERROR, '4'=WAIT ERROR, '5'=ARGUMENT
;  ERROR (FLAG NOT '0' OR '1').
	CLR	DSKERR	; FOR I/O ERROR REPORT
	TST	OPENF	; DISK FILE ALREADY OPENED?
	BNE	20$
	.if df cmdline ;command line input and choice of task name
;set task name with RUN FORTH/TASK=BLAH and it will use BLAH.DAT as data file
	sub	#32.,sp	;make space on stack
	mov	sp,r1	;copy pointer
	gtsk$s	r1	;get task name and other stuff we don't care about
	mov	(r1),defnmb+n.fnam ;overwrite default with task name...
	mov	2(r1),defnmb+n.fnam+2
	add	#32.,sp	;restore stack pointer
	open$m	#fdbio	;try to open with taskname as filename
	bcc	20$	;continue if OK
	mov	#^rFOR,defnmb+n.fnam ;else put FORTH back as filename
	mov	#^rTH,defnmb+n.fnam+2 ;...
	.endc	;cmdline
	OPEN$M	#FDBIO
	BCC	20$
	MOV	#1,DSKERR	; ERROR IN OPEN
	BR	ERRR
20$:	MOV	#1,OPENF	; INDICATE FILE IS OPEN
	CLR	VIRBLK
	MOV	2(S),VIRBLK+2	; SET UP VIRTUAL BLOCK NUMBER
	MOV	4(S),IOADDR	; SET UP I/O ADDRESS
	TST	(S)		; WAS TOP OF STACK - READ OR WRITE?
	BEQ	WRITE
	CMP	(S),#1
	BEQ	READ
	MOV	#5,DSKERR	; ERROR, FLAG NOT EITHER '0' OR '1'
	BR	ERRR
READ:	READ$	#FDBIO,IOADDR,,#VIRBLK,#2
	BCC	WAIT
	MOV	#2,DSKERR	; ERROR IN READ
	BR	ERRR
WRITE:	WRITE$	#FDBIO,IOADDR,,#VIRBLK,#2
	BCC	WAIT
	MOV	#3,DSKERR	; ERROR IN WRITE
	BR	ERRR
WAIT:	WAIT$
	BCC	DONE
	MOV	#4,DSKERR	; ERROR IN WAIT
	BR	ERRR
DONE:	ADD	#6,S
	CLR	-(S)		; INDICATE GOOD I/O
	BR	DONE2
ERRR:	ADD	#6,S
	MOV	DSKERR,-(S)	; RETURN THE ERROR INDICATOR
	MOV	#1,-(S)		; INDICATE ERROR IN I/O
DONE2:	NEXT
	fsrsz$	0
fdbio:	fdbdf$
	fdrc$a	fd.rwm
	fdbk$a	,512.,,2,iostat
	.if ndf newtio
	fdop$a	3,descr,,fo.mfy
	.iff
	 .if ndf cmdline
	  fdop$a	1,descr,,fo.mfy
	 .iff	;cmdline
	  fdop$a	1,,defnmb,fo.mfy
	 .endc	;cmdline
	.endc	;newtio
	.if ndf cmdline
DESCR:	.WORD	0,0		; USE DEFAULT DEVICE
	.WORD	0,0		; AND DIRECTORY.
	.WORD	FILSZ,FIL
FIL:	.ASCII	/FORTH.DAT/
FILSZ=.-FIL
	.EVEN
	.iff	;cmdline
defnmb:	nmblk$	FORTH,DAT,,,
	.endc	;cmdline
;
OPENF:	.WORD	0		; FLAG FOR FIRST TIME DISK I/O
;  DO NOT INITIALIZE 'OPENF' AT COLD START
DSKERR:	.WORD	0		; SPACE FOR DISK ERROR MESSAGE
IOADDR:	.WORD	0		; ADDRESS FOR DISK READ/WRITE
IOSTAT:	.BLKW	2		; I/O STATUS REPORT
VIRBLK:	.BLKW	2		; VIRTUAL BLOCK NUMBER
;
	HEAD	212,BLOCK-READ,240,BREAD,DOCOL		; ***** BLOCK-READ
; ( ADDRESS BLOCK# ==> REPORT).  REPORT: 0=GOOD READ, ELSE ERROR
	.WORD	ONE,XIO,SEMIS
;
	HEAD	213,BLOCK-WRITE,305,BWRIT,DOCOL		; ***** BLOCK-WRITE
; ( ADDRESS BLOCK# ==> REPORT).  REPORT: 0=GOOD WRITE, ELSE ERROR
	.WORD	ZERO,XIO,SEMIS
;
	HEAD	203,I/O,317,IO,DOCOL			; ***** I/O
; READ OR WRITE 512-BYTE BLOCK, HANDLE ERRORS.
; ( ADDRESS BLOCK# FLAG(1=READ,0=WRITE) ==> )
	.WORD	DUP,ONE,EQUAL,ZBRANCH,XXS1-.,DROP,BREAD
	.WORD	ZBRANCH,XXS2-.,CR
	.pdotq	<DISK READ ERROR # >
	.WORD	DOT,ABORT
XXS2:	.WORD	BRANCH,XXS3-.
XXS1:	.WORD	ZEQU,ZBRANCH,XXS4-.,BWRIT,ZBRANCH,XXS5-.
	.WORD	CR
	.pdotq	<DISK WRITE ERROR # >
	.WORD	DOT,ABORT
XXS5:
XXS4:
XXS3:	.WORD	SEMIS
;
	HEAD	203,R/W,327,RW,DOCOL			; ***** R/W
; READ OR WRITE 1024-BYTE SCREEN.  ( ADDRESS SCREEN# FLAG ==> )
; NOTE THAT SCREEN N IS BLOCKS 2N-1 AND 2N.
	.WORD	TOR,TWO,STAR,OVER,OVER,ONE,SUB,R,IO
	.WORD	SWAP,LIT,512.,PLUS
	.WORD	SWAP,FROMR,IO,SEMIS
;
	.ENDC
;
; ***************
;
; RT-11 TERMINAL I/O
;
; ***************
;
	.IFDF	RT11
ITERM:	CMP	INTERM,#-1
	BNE	RTRTS
	CLR	INTERM
	.RCTRLO			; RESET CNTL-O
	.TRPSET	#TRAPBL,#TRAPZ
RTRTS:	RTS	R1
;
PEMIT:
	JSR	R1,ITERM
;  INCREMENT 'OUT', UNLESS A CONTROL CHARACTER BEING OUTPUT.
	CMP	(S),#40		; TEST FOR CONTROL CHARACTER
	BLT	1$
	INC	42(U)		; INCREMENT 'OUT'
1$:
	JSR	R1,XCOUT
	NEXT
;
PKEY:	JSR	R1,ITERM
	.TTYIN
	BIC	#177600,R0
	CMP	R0,#12		; IGNORE LINEFEED
	BEQ	PKEY
	MOV	R0,-(S)
	NEXT
;
PQTER:	JSR	R1,ITERM
	MOV	44,-(RP)	; SAVE JSW
	BIS	#10100,44	; SET BITS 6  AND 12 OF JSW
	.TTINR
	BCC	1$
;  IF CARRY SET, NO CHARACTER - SUPPLY ZERO
	CLR	R0
1$:	BIC	#177600,R0
	CMP	R0,#12		; IGNORE LINEFEED
	BNE	2$
	CLR	R0
2$:	MOV	R0,-(S)
	MOV	(RP)+,44	; RESTORE JSW
	NEXT
;
PCR:	JSR	R1,ITERM
	MOV	#15,-(S)
	JSR	R1,XCOUT
	MOV	#12,-(S)
	JSR	R1,XCOUT
	NEXT
;
XCOUT:	MOV	(S)+,R0
	.TTYOUT
	RTS	R1
;
INTERM:	.WORD	-1			; FLAG FOR FIRST TIME TERMINAL I/O
;  DO NOT INITIALIZE 'INTERM' AT COLD START
IOCHR:	.WORD	0			; TEMPORARY AREA FOR 'KEY', 'EMIT'
;
	HEAD	203,BYE,305,BYE				; ***** BYE (RT)
	.EXIT
;
;
; ***************
;
; RT-11 DISK I/O
;
; ***************
;
	HEAD	204,XI/O,240,XIO			; ***** XI/O (RT)
	CLR	DSKERR
	TST	OPENF
	BNE	RTOPEN
	MOV	#1,OPENF	; INDICATE FILE IS OPEN
; NOW OPEN THE FILE
	.SETTOP	#-2
	MOV	#RTSTAT,R1
	.DSTATUS R1,#RTFILE
	BCC	1$
	MOV	#1,DSKERR
	BR	RTRET
1$:	TST	4(R1)		; HANDLER IN?
	BNE	2$
	.FETCH	HANDLR,#RTFILE	
	BCC	2$
	MOV	#2,DSKERR
	BR	RTRET
2$:	.LOOKUP	#LOOK1,#0,#RTFILE
	BCC	RTOPEN
	MOV	#3,DSKERR
	BR	RTRET
RTOPEN:	   ; FILE IS OPEN - NOW READ IT
	MOV	2(S),R1	; BLOCK #
	DEC	R1		; BEGINS AT 1 IN FORTH
	MOV	4(S),IOADDR	; BUFFER ADDRESS
	TST	(S)
	BEQ	WRITE
	CMP	(S),#1
	BEQ	READ
	MOV	#5,DSKERR
	BR	RTRET
READ:	.READW	#RTBLK,#0,IOADDR,,R1
	BCC	1$
	MOV	#6,DSKERR
1$:	BR	RTRET
WRITE:	.WRITW	#RTBLK,#0,IOADDR,,R1
	BCC	2$
	MOV	#7,DSKERR
2$:	BR	RTRET
RTRET:	ADD	#6,S
	MOV	DSKERR,-(S)
	TST	DSKERR
	BEQ	1$
	MOV	#1,-(S)		; INDICATE ERROR OCCURRED
1$:	NEXT
RTFILE:	.RAD50	/DK FORTH DAT/
RTBLK:	.BYTE	0,10
	.WORD	0,0,256.,0
;
OPENF:	.WORD	0		; FLAG FOR FIRST TIME DISK I/O
DSKERR:	.WORD	0		; SPACE FOR DISK ERROR MESSAGE
IOADDR:	.WORD	0		; ADDRESS FOR DISK READ/WRITE
RTSTAT:	.BLKW	4		; DISK I/O STATUS
LOOK1:	.BLKW	3		; EMT ARGUMENT BLOCK
TRAPBL:	.BLKW	2		; EMT ARGUMENT BLOCK
;
	HEAD	212,BLOCK-READ,240,BREAD,DOCOL		; ***** BLOCK-READ
; ( ADDRESS BLOCK# ==> REPORT).  REPORT: 0=GOOD READ, ELSE ERROR
	.WORD	ONE,XIO,SEMIS
;
	HEAD	213,BLOCK-WRITE,305,BWRIT,DOCOL		; ***** BLOCK-WRITE
; ( ADDRESS BLOCK# ==> REPORT).  REPORT: 0=GOOD WRITE, ELSE ERROR
	.WORD	ZERO,XIO,SEMIS
;
	HEAD	203,I/O,317,IO,DOCOL			; ***** I/O
; READ OR WRITE 512-BYTE BLOCK, HANDLE ERRORS.
; ( ADDRESS BLOCK# FLAG(1=READ,0=WRITE) ==> )
	.WORD	DUP,ONE,EQUAL,ZBRANCH,XXS1-.,DROP,BREAD
	.WORD	ZBRANCH,XXS2-.,CR
	.pdotq	<DISK READ ERROR # >
	.WORD	DOT,ABORT
XXS2:	.WORD	BRANCH,XXS3-.
XXS1:	.WORD	ZEQU,ZBRANCH,XXS4-.,BWRIT,ZBRANCH,XXS5-.
	.WORD	CR
	.pdotq	<DISK WRITE ERROR # >
	.WORD	DOT,ABORT
XXS5:
XXS4:
XXS3:	.WORD	SEMIS
;
	HEAD	203,R/W,327,RW,DOCOL			; ***** R/W
; READ OR WRITE 1024-BYTE SCREEN.  ( ADDRESS SCREEN# FLAG ==> )
; NOTE THAT SCREEN N IS BLOCKS 2N-1 AND 2N.
	.WORD	TOR,TWO,STAR,OVER,OVER,ONE,SUB,R,IO
	.WORD	SWAP,LIT,512.,PLUS
	.WORD	SWAP,FROMR,IO,SEMIS
;
;
	.ENDC
;
; ***************
;
; STAND-ALONE TERMINAL I/O
;
; ****************
;
	.IFDF	ALONE
PEMIT:
;  INCREMENT 'OUT', UNLESS A CONTROL CHARACTER BEING OUTPUT.
	CMP	(S),#40		; TEST FOR CONTROL CHARACTER
	BLT	1$
	INC	42(U)		; INCREMENT 'OUT'
1$:	TST	@#177564
	BEQ	1$
	MOV	(S)+,@#177566
	NEXT
;
PKEY:	TSTB	@#177560
	BEQ	PKEY
	CLR	@#177560
	MOVB	@#177562,R1
	BIC	#177600,R1
	CMP	#177,R1
	BNE	1$
	MOV	#10,R1
1$:	MOV	R1,-(S)
	NEXT
;
PQTER:	TSTB	@#177560
	BEQ	1$
	MOV	@#177562,-(S)
	BR	2$
1$:	CLR	-(S)
2$:	CLR	@#177560
	NEXT
;
PCR:	TST	@#177564
	BEQ	PCR
	MOV	#15,@#177566
1$:	TST	@#177564
	BEQ	1$
	MOV	#12,@#177566
	NEXT
;
	HEAD	203,BYE,305,BYE				; ***** BYE (ALONE)

	HALT
;
; ***************
;
;  STAND-ALONE DISK I/O
;
; ***************
;
RXCS=177170	; CONTROL AND STATUS REGISTER
RXDB=177172	; DATA BUFFER REGISTER
;
;
	HEAD	204,NRTS,240,NRTS			; ***** NRTS
;  ADDRN TRN SECN...ADDR1 TR1 SEC1 N -> FLAG
;  READ N SECTORS.  USES R0, R1, R2
;  THIS OPERATION IS IN CODE TO KEEP UP WITH DISK TIMING FOR
;  STANDARD PDP-11 SECTOR SKEWING.
	MOV	(S)+,R1		; # OF SECTORS TO READ
1$:	MOV	#10,R2		; RETRY COUNT
21$:	MOV	#7,R0		; 'READ' COMMAND
	JSR	PC,DRIV2	; ADJUST R0 COMMAND 
				; IF SECOND DRIVE
	MOV	R0,@#RXCS		; READ COMMAND
2$:	BIT	#200,@#RXCS	; WAIT FOR TRANSFER FLAG
	BEQ	2$
	MOV	(S),@#RXDB	; SECTOR #
3$:	BIT	#200,@#RXCS	; WAIT FOR TRANSFER FLAG
	BEQ	3$
	MOV	2(S),@#RXDB	; TRACK #
4$:	BIT	#40,@#RXCS	; WAIT FOR DONE FLAG
	BEQ	4$
;  CHECK FOR ERROR
	TST	@#RXCS
	BLT	20$		; ERROR
;
	MOV	#3,@#RXCS	; 'EMPTY' COMMAND
;  EMPTY THE CONTROLLER'S BUFFER
	MOV	4(S),R0		; ADDRESS TO RECEIVE DATA
	MOV	#200,-(S)	; COUNT OF TIMES TO LOOP
6$:	BIT	#200,@#RXCS	; WAIT FOR TRANSFER FLAG
	BEQ	6$
	MOVB	@#RXDB,(R0)+
	DEC	(S)		; DECREMENT THE COUNT
	BNE	6$
	TST	(S)+		; POP THE COUNT
;  CHECK FOR ERROR
	TST	@#RXCS
	BGE	7$
20$:  ; ERROR, SO RE-TRY
	MOV	#40000,@#RXCS	; CLEAR ERROR STATUS
22$:	BIT	#40,@#RXCS
	BEQ	22$
	DEC	R2		; RE-TRY COUNT
	BGT	21$
	MOV	#-1,-(S)
	NEXT			; ERROR EXIT
7$:	ADD	#6,S		; GOOD READ, SO POP THE 3 ARGS
	DEC	R1
	BNE	1$		; LOOP UNLESS ALL SECTORS READ
;
	CLR	-(S)		; GOOD-READ INDICATOR
	NEXT			; EXIT
;
;  SUBROUTINE TO ADJUST COMMAND FOR SECOND DISK DRIVE
;  NOTE - 'NWTS' ALSO USES THIS SUBROUTINE.
;  NOTE USE OF R0, AND OF FORTH STACK.
DRIV2:	CMP	2(S),#114	; TRACK > 76 ?
	BLE	10$
	SUB	#115,2(S)	; SUBTRACT 77
	BIS	#20,R0		; SET UNIT-SELECT BIT
10$:	RTS	PC
;
	HEAD	204,NWTS,240,NWTS			; ***** NWTS
;  ADDRN TRN SECN...ADDR1 TR1 SEC1 N -> FLAG
;  WRITE N SECTORS.  USES R0, R1, R2.
	MOV	(S)+,R1		; # OF SECTORS TO BE WRITTEN
1$:	MOV	#10,R2		; RE-TRY COUNT
21$:	MOV	#1,@#RXCS	; 'FILL' COMMAND
2$:	BIT	#200,@#RXCS	; WAIT FOR TRANSFER FLAG
	BEQ	2$
;  NOW FILL THE BUFFER
	MOV	4(S),R0
	MOV	#200,-(S)	; COUNT
3$:	BIT	#200,@#RXCS	; WAIT FOR TRANSFER FLAG
	BEQ	3$
	MOVB	(R0)+,@#RXDB	; MOVE ONE BYTE
	DEC	(S)
	BNE	3$
	TST	(S)+		; POP STACK
;  CHECK FOR ERROR
	TST	@#RXCS
	BLT	20$		; ERROR
;
	MOV	#5,R0		; 'WRITE' COMMAND
	JSR	PC,DRIV2	; ADJUST IF SECOND DRIVE
	MOV	R0,@#RXCS		; 'WRITE' COMMAND
5$:	BIT	#200,@#RXCS	; WAIT FOR TRANSFER FLAG
	BEQ	5$
	MOV	(S),@#RXDB	; MOVE SECTOR #
6$:	BIT	#200,@#RXCS	; WAIT FOR TRANSFER FLAG
	BEQ	6$
	MOV	2(S),@#RXDB	; MOVE TRACK #
7$:	BIT	#40,@#RXCS	; WAIT FOR DONE FLAG
	BEQ	7$
;  CHECK FOR ERROR
	TST	@#RXCS
	BGE	10$
20$:  ; ERROR SO RE-TRY
	MOV	#40000,@#RXCS	; CLEAR ERROR STATUS
22$:	BIT	#40,@#RXCS
	BEQ	22$
	DEC	R2		; RE-TRY COUNT
	BGT	21$
	MOV	#-1,-(S)	; ERROR INDICATOR
	NEXT			; EXIT
10$:	ADD	#6,S		; GOOD WRITE, SO POP THE 3 ARGS
	DEC	R1
	BNE	1$		; LOOP UNLESS ALL SECTORS WRITTEN
;
	CLR	-(S)		; GOOD-WRITE INDICATOR
	NEXT
;
	HEAD	203,RTS,323,RTS,DOCOL			; ***** RTS
;  ADDR TR SEC ->
;  READ A SINGLE SECTOR.
	.WORD	ONE,NRTS,ZBRANCH,1$-.
	.pdotq	<DISK READ ERROR IN RTS>
	.WORD	QUIT
1$:	.WORD	SEMIS
;
	HEAD	203,WTS,323,WTS,DOCOL			; ***** WTS
;  ADDR TR SEC ->
;  WRITE A SINGLE SECTOR.
	.WORD	ONE,NWTS,ZBRANCH,1$-.
	.pdotq	<DISK WRITE ERROR IN WTS >
	.WORD	QUIT
1$:	.WORD	SEMIS
;
;
	HEAD	205,SKEW1,261,SKEW1,DOCOL		; ***** SKEW1
;  SEQUENCE -> TRACK SECTOR
;  HANDLE THE SECTOR SKEWING.
;  NOTE - 'SEQUENCE #' IS ZERO-ORIGIN INDEX OF SECTOR (SKEWED).
;  NOTE - 'SKEW1' DOES SKEWING OF ONLY ONE DRIVE; 'SKEW' GENERALIZES
;  'SKEW1' TO BOTH DRIVES.
	.WORD	DUP,LIT,32,SLASH,SWAP
	.WORD	OVER,LIT,6,STAR,OVER,DUP,PLUS,PLUS,SWAP
	.WORD	   LIT,32,MOD,LIT,15,SLASH,PLUS
	.WORD	   LIT,32,MOD,ONEP
	.WORD	SWAP,ONEP,SWAP,SEMIS
;
	HEAD	206,S-SKIP,240,SSKIP,DOVAR		; ***** S-SKIP
;  VARIABLE - NUMBER OF SECTORS SKIPPED AT BEGINNING OF DISK.
;  DEFAULT IS 56 DECIMAL (SKIP AN RT-11 DIRECTORY).  ALSO, TRACK
;  ZERO IS SKIPPED, FOR COMPATIBILITY.
	.WORD	56.
;
	HEAD	206,S-USED,240,SUSED,DOVAR		; ***** S-USED
;  VARIABLE - NUMBER OF SECTORS USED ON ON ONE DISK.
;  NORMALLY, S-USED + S-SKIP = 1976. (2002. - 26. OF TR 0).
	.WORD	1920.
;
	HEAD	204,SKEW,240,SKEW,DOCOL			; ***** SKEW
;  SEQUENCE# -> TRACK SECTOR
	.WORD	DUP,ONEP,SUSED,AT,GREAT,ZBRANCH,1$-.
	.WORD	SUSED,AT,SUB,SSKIP,AT,PLUS,SKEW1
	.WORD	SWAP,LIT,77.,PLUS,SWAP
	.WORD	BRANCH,2$-.
1$:	.WORD	SSKIP,AT,PLUS,SKEW1
2$:	.WORD	SEMIS
;
	HEAD	206,NSETUP,240,NSET,DOCOL		; ***** NSETUP
;  ADDR SEQUENCE# N -> ADDRN TRN SECN...ADDR1 TR1 SEC1
;  THIS PREPARES A WHOLE SCREEN (IF N=8) FOR 'NRTS' OR 'NWTS'.
	.WORD	ROT,OVER,LIT,128.,STAR,PLUS,ROT,ROT
	.WORD	OVER,PLUS,ONE,SUB,SWAP,ONE,SUB,SWAP
	.WORD	XDO
2$:	.WORD	LIT,128.,SUB,DUP,I,SKEW,ROT
	.WORD	LIT,-1,XPLOOP,2$-.
	.WORD	DROP,SEMIS
;
	define	rw,R/W,docol				; ***** R/W
;Read or write 1024-byte screen ( addr block# flag[r=1,w=0] ==>)
	.word	tor,one,sub,lit,8.,star,fromr
;Change the screen # to first sequence #; If read, setup and read 8 sectors.
	.word	zbranch,20$-.,lit,8.,nset,lit,8.,nrts
	.word	zbranch,10$-.
	.pdotq	<DISK READ ERROR >
	.word	quit
10$:	.word	branch,30$-.
;  setup and write 8 sectors
10$:	.word	lit,8.,nset,lit,8.,nwts
	.word	zbranch,30$-.
	.pdotq	<DISK WRITE ERROR>
	.word	quit
30$:	.word	semis
;
	.endc	;alone
;
; ***************
;
;	TRAP RECOVERY SECTION, RSX-11M
;
; ***************
;
	.IFNDF	ALONE	; STAND-ALONE MUST HANDLE OWN INTERRUPTS.
	HEAD	205,TRAPS,323,TRAPS,DOCOL		; ***** TRAPS
	.WORD	CR
	.pdotq	<TRAP-ERROR, >
	.WORD	DOT,SWAP,UDOT,UDOT,QUIT
	.ENDC
;
	.IFDF	RSX11
TRAPV:	.WORD	TRAP0,TRAP1,TRAP2,TRAP3,TRAP4,TRAP5
TRAP0:	CLR	R1			; TRAP # 0
	BR	TRAPZ
TRAP1:	MOV	#1,R1			; TRAP # 1
	ADD	#6,SP			; DROP MMU INFO
	BR	TRAPZ
TRAP2:	MOV	#2,R1
	BR	TRAPZ
TRAP3:	MOV	#3,R1
	BR	TRAPZ
TRAP4:	MOV	#4,R1
	BR	TRAPZ
TRAP5:	MOV	#5,R1
	BR	TRAPZ
;  TO RETURN FROM TRAP HANDLER, SET UP STACK, ETC. FOR FORTH 'TRAPS'
;  DON'T USE RTT OR RTI.
TRAPZ:	MOV	(SP)+,-(S)	; PC
	MOV	(SP)+,-(S)	; PS
	MOV	R1,-(S)		; TRAP #
	MOV	#TRAPS+2,IP	; EXECUTE 'TRAPS'
	NEXT
;
	.ENDC
; ****************
;
;  TRAP RECOVERY SECTION, RT-11
;
; ****************
	.IFDF	RT11
TRAPZ:	BCS	1$
;  IF CARRY CLEAR, TRAP 4
	MOV	#4,R1
	BR	2$
1$:	MOV	#10,R1
2$:	MOV	(SP)+,-(S)		; PC
	MOV	(SP),-(S)		; PS
	MOV	R1,-(S)			; TRAP #
	MOV	#3$,-(SP)		; SO RTI WILL RESTORE PC TO '3$'
	.TRPSET	#TRAPBL,#TRAPZ		; RE-SET TRAPS
	RTI
3$:	MOV	#TRAPS+2,IP		; EXECUTE 'TRAPS'
	NEXT
	.ENDC
;
;(Reference to .DW deleted, since it was incomplete anyway [routine XCOUT
; was shown as a variable not a subroutine] and in any case had only historical
; value.)
;
; ****************************************************************
;
;  THE FOLLOWING TWO DEFINITIONS ARE NOT PURE CODE, SO THEY WERE
;  MOVED HERE, NEAR THE END OF THE DICTIONARY.
;
; ****************************************************************
;
	.immediate
	define	semic,<;CODE>,docol			; ***** ;CODE
;Create routine written in assembly
	.word	qcsp,comp,pscod,lbrac,smudg,semis
;The assembler will patch this definition when it is loaded
;
	.immediate
	define	forth,FORTH,dodoe			; ***** FORTH
	.word	dovoc,120201,xxvoc+2 ;dummy header, space
xxvoc:	.word	0	;the vocabulary link
;
	define	task,TASK,docol				; ***** TASK
	.word	semis	;boundary marker
;
.PAGE
; ****************************************************************
;
;  STACKS AND BUFFERS
;
; ****************************************************************
;
;  NOTE - 'UP', 'OPENF', 'INTERM', AND DISK BUFFERS ARE
;  INITIALIZED AT COLD START, OR AT FIRST TIME THROUGH.
	.EVEN
XDP:				; DICTIONARY STARTS HERE
	.BLKB	16000.		; FOR DICTIONARY AND COMP. STACK
; INCREASE THIS NUMBER TO USE A LARGER MEMORY SIZE.
XS0:				; START OF COMPUTATION STACK
	.BLKW	2		; IN CASE OF EMPTY STACK
;
;
;
;
;
DSKBUF:		; ROOM  FOR 3 1K DISK BUFFERS
; INITIALIZE BUFFERS' UPDATE BITS, AND TERMINATING NULLS, TO ZERO.
; NOTE - THESE BUFFERS ARE CLEARED AT COLD START, ANYWAY,
; BECAUSE A STAND-ALONE BOOT MAY NOT INITIALIZE HIGH MEMORY;
; AND ALSO SO THAT THE NUMBER OR LOCATION OF BUFFERS CAN BE
; CHANGED AT RUN TIME.
	.WORD	0
	.BLKB	1024.
	.WORD	0
	.WORD	0
	.BLKB	1024.
	.WORD	0
	.WORD	0
	.BLKB	1024.
	.WORD	0
ENDBUF:		; CAUTION - 'ENDBUF' - 'DSKBUF' MUST BE EXACT MULTIPLE
; OF THE BUFFER LENGTH PLUS 4.
;
; 'XTIB', 'XR0', AND 'XUP' ARE ONLY USED IN BOOT-UP TABLE; 
;  THEREFORE THE AREAS DEFINED HERE CAN BE MOVED AT RUN TIME.
XTIB:	.BLKW	42.		; TERMINAL INPUT BUFFER
	.BLKW	50.		; FOR RETURN STACK
XR0=.
XUP:	.BLKW	100		; ROOM FOR 100 USER VARIABLES
;
;
	.IFDF	RT11
;  DISK HANDLER GOES HERE
HANDLR:	.WORD	.+2
	.ENDC
;
;
;  NOTE - CHANGE THE FOLLOWING LINE TO '.END' IF LINKING TO OTHER LANGUAGES.
	.END	ORIGIN