******************************************************
*               HTPL  RUNTIME LIBRARY                *
* COPYRIGHT 1986 JOSEPH BARTEL - ALL RIGHTS RESERVED *  
* ------------- SPECIAL -----------------------------*
* THIS HAS LOCAL VARIABLES -- NEEDS SPECIAL COMPILER *
******************************************************
	ORG	0
	DC.W	RTEND		;SIZE OF MODULE, EVEN
	DC.W	43		;ENTRY COUNT
;- 7 -- STRING
	DC.B	'LENGTH      '	;LENGTH OF STRING
	DC.W	LENGTH
	DC.B	'CONCAT      '
	DC.W	CONCAT
	DC.B	'COPY        '
	DC.W	COPY
	DC.B	'CCOMP       '
	DC.W	CCOMP
	DC.B	'DELETE      '
	DC.W	DELETE
	DC.B	'POS         '
	DC.W	POS
	DC.B	'SCOMP       '
	DC.W	SCOMP
	DC.B	'CHMATCH     '
	DC.W	CHMATCH
;- 7 -- ARITHMETIC
	DC.B	'/           '
	DC.W	DIV
	DC.B	'MOD         '
	DC.W	MOD
	DC.B	'*           '
	DC.W	MULT
	DC.B	'*/          '
	DC.W	MDIV
	DC.B	'RANGE       '
	DC.W	RANGE
	DC.B	'DBLINC      '
	DC.W	DBLINC
	DC.B	'DBLDEC      '
	DC.W	DBLDEC
;- 13 -- I/O
	DC.B	'GETLINE     '
	DC.W	GETLIN
	DC.B	'IPRINT      '
	DC.W	IPRINT
	DC.B	'FPRINT      '
	DC.W	FPRINT
	DC.B	'BIPRINT     '
	DC.W	BIPRINT
	DC.B	'BFPRINT     '
	DC.W	BFPRINT
	DC.B	'PUTC        '
	DC.W	PUTC
	DC.B	'SPRINT      '
	DC.W	SPRINT
	DC.B	'APRINT      '
	DC.W	APRINT
	DC.B	'SPACES      '
	DC.W	SPACES
	DC.B	'TRAP        '
	DC.W	TRAP	
	DC.B	'GETC        '
	DC.W	GETC
	DC.B	'IGET        '
	DC.W	IGET
	DC.B	'FGET        '
	DC.W	FGET
;- 8 -- GENERIC USEFUL
	DC.B	'FILL        '
	DC.W	FILL
	DC.B	'MOVEC       '
	DC.W	MOVEC
	DC.B	'MOVER       '
	DC.W	MOVER
	DC.B	'TRUE        '
	DC.W	TRUE
	DC.B	'FALSE       '
	DC.W	FALSE 
	DC.B	'RESET       '
	DC.W	RESET
	DC.B	'EXIT        '
	DC.W	EXIT
;- 8 -- HEAP / STORAGE -- MANAGEMENT ROUTINES
	DC.B	'ALLOCATE    '
	DC.W	ALLOCATE
	DC.B	'RECLAIM     '
	DC.W	RECLAIM
	DC.B	'MARK        '
	DC.W	MARK
	DC.B	'RELEASE     '
	DC.W	RELEASE
	DC.B	'NEWHEAP     '
	DC.W	NEWHEAP
	DC.B	'SETLOCAL    '
	DC.W	SETLOCAL
	DC.B	'GETLOCAL    '
	DC.W	GETLOCAL
	DC.B	'LOCALSIZ    '
	DC.W	LOCALSIZ
******************************************
*    ACTUAL CODE STARTS HERE             * 
******************************************
; A3 - RTL BASE          D7 - ALWAYS 0
; A4 - EVAL STACK
; A5 - LOCAL VARS
; A6 - COMMON VARS
; A7 - RETURN STACK
;-----------------------------------------------------------
	ORG	0
START	BRA	START2			;SKIP OVER CONSTANTS
COMSIZ	DC.W	0			;SIZE OF COMMON VARS
VARSIZ	DC.W	0			;SIZE OF LOCAL VARS
PROGSIZ	DC.W	0			;SIZE OF PROGRAM
PROGO	DC.W	0			;START OF EXECUTION
	DC.W	0,0			;FILL OUT FIRST REC
	DC.W	RTEND			;SIZE OF RTL
START2	LEA	START-START2-2(PC),A3	;SET START OF ROUTINES
	LEA	RTEND(A3),A6		;SET START OF COMMON VARS
	MOVEA.L	A6,A0			;COPY COMMON BASE
;=====	ADDA.W	VARSIZ(A3),A0	;======= KLUDGE TO GET NEW =========
	ADDA.W	COMSIZ(A3),A0		;CALCULATE START OF PROG
	MOVEA.L	A0,A1			;NOW FIGURE HEAP
	ADDA.W	PROGSIZ(A3),A1		;A1 HAS START OF HEAP
	LEA	512(A1),A7		;SET RETURN STACK
	LEA	512(A7),A4		;SET EVALUATION STACK
	MOVEA.L	A4,A5			;SET LOCALS ON HEAP
	MOVE.L	A4,HEAPL(A3)		;SAVE FOR HEAP ALLOCATE
	MOVE.L	A4,HEAPS(A3)		;SAVE FOR RESET
	CLR.L	D7			;FIX FOR BYTE OPERATIONS
	CLR.L	D0
	MOVE.W	PROGO(A3),D0
	JMP	0(A0,D0.L)		;GO TO IT
	DC.L	0
RTL	DC.L	12188600H		;VERSION NUMBER
*---- RUN TIME LIBRARY ROUTINES
*---- RESET RETURN AND EVALUATION STACKS
RESET	MOVEA.L	(A7)+,A0		;SAVE RETURN ADDRESS
	LEA	RTEND(A3),A6		;START OF COMMON
	MOVEA.L	A6,A1
;======	ADDA.W	VARSIZ(A3),A1		;====== KLUDGE START =======
	ADDA.W	COMSIZ(A3),A1		;START OF PROG
	ADDA.W	PROGSIZ(A3),A1		;START OF MEM
	LEA	512(A1),A7		;SET RETURN STACK
	LEA	512(A7),A4		;SET EVAL STACK
	JMP	(A0)			;RETURN
****** ---- HEAP MANAGEMENT ROUTINES ---- ******
; ( size -- pointer )
ALLOCATE MOVE.L	(A4),D0			;GET SIZE
	MOVE.L	HEAPL(A3),(A4)		;POINT TO START
	ADD.L	D0,HEAPL(A3)		;BUMP POINTER
	RTS
; ( size -- )
RECLAIM	MOVE.L	(A4)+,D0		;GET SIZE
	SUB.L	D0,HEAPL(A3)		;BUMP POINTER
	RTS
; ( -- pnt ) MARK like in turbo pascal
MARK	MOVE.L	HEAPL(A3),-(A4)
	RTS
; ( pnt -- ) RELEASE  like in turbo pascal
RELEASE	MOVE.L	(A4)+,HEAPL(A3)
	RTS
; ( -- )
NEWHEAP	MOVE.L	HEAPS(A3),HEAPL(A3)	;RESET HEAP
	RTS
;---- SET LOCAL STORAGE POINTER  ( pn -- )
SETLOCAL
	MOVEA.L	(A4)+,A5
	RTS
;---- GET LOCAL STORAGE POINTER  (  -- pn )
GETLOCAL
	MOVE.L	A5,-(A4)
	RTS
;---- GET SIZE OF LOCAL STORAGE  (  -- siz )
LOCALSIZ
	MOVEQ.L	#0,D0			;CLEAR D0
	MOVE.W	VARSIZ(A3),D0		;GET SIZ WORD
	MOVE.L	D0,-(A4)		;PUT ON STACK
	RTS
******************************************
*           STRING ROUTINES              *
******************************************
;--- FIND LENGTH OF STRING  ( str -- len )
LENGTH	MOVEA.L	(A4),A0		;COPY STRING START
LLOOP	TST.B	(A0)+		;TEST AND INC
	BNE	LLOOP		;UNTIL A 0
	SUBA.L	(A4),A0		;SUBTRACT START
	SUBQ.L	#1,A0		;CORRECT
	MOVE.L	A0,(A4)		;PUT BACK ON STACK
	RTS			;ALL DONE	
;--- DELETE PART OF STRING  ( str pos num -- )
DELETE	MOVE.L	(A4)+,D6	;NUM TO DELETE
	MOVE.L	(A4)+,D5	;PLACE TO START
	MOVE.L	(A4)+,D4	;STRING ADRESS
	MOVEA.L	D4,A2		;SET FOR FIND SIZE
DEL020	TST.B	(A2)+		;FIND END OF STRING
	BNE	DEL020
	MOVEA.L	D4,A0		;A0=STRING+POS
	ADDA.L	D5,A0
	LEA	0(A0,D3),A1	;A1=STR+POS+NUM
	CMPA	A2,A0		;CHECK SIZE
	BLE.S	DEL350
	CMPA	A2,A1
	BGT.S	DEL300
	CLR.B	(A0)		;TRUNC STRING
	RTS
DEL300	MOVE.B	(A1)+,(A0)+	;COPY BYTES
	BNZ	DEL300		;UNTIL END
DEL350	RTS			;GO HOME	
;--- INSERT INTO STRING  ( obj str pos -- )
INSERT
;--- RETURN COPY OF PART OF STRING  ( obj src pos num -- )
PART
;--- CONCATENATE  SRC=SRC+OBJ  ( src obj -- )
CONCAT	MOVEA.L	(A4)+,A0	;OBJECT
	MOVEA.L	(A4)+,A1	;SRC
CON020	TST.B	(A1)+		;FIND END OF SRC
	BNZ	CON020		;MARKED WITH NULL
	SUBQ	#1,A1		;BACK UP
CON040	MOVE.B	(A0)+,(A1)+	;CONCAT!
	BNZ	CON040		;
	RTS			;GO HOME
;--- COPY ( src dst -- )
COPY	MOVEA.L	(A4)+,A0	;DEST
	MOVEA.L	(A4)+,A1	;SRC
COP020	MOVE.B	(A1)+,(A0)+	;MOVE BYTES
	BNZ	COP020		;UNTIL NULL
	RTS			;THEN EXIT
;----- CHARACTER MATCH  ( str char -- pos )
CHMATCH	MOVE.L	(A4)+,D0	;GET CHAR
	MOVEA.L	(A4),A1		;GET STRING
CHM100	CMP.B	(A1)+,D0	;CHECK CHAR
	BNE	CHM100
	SUBQ.L	#1,A1		;BACK UP
	MOVE.L	A1,(A4)		;BACK ON STACK
	RTS
;--- POSITION IN OTHER STRING ( obj src -- pos )
POS	MOVE.L	(A4)+,D3	;LOOKIN
	MOVE.L	(A4),D6		;LOOKFOR
POS020	MOVEA.L	D6,A0		;MAKE LOOKFOR ADRS
	MOVEA.L	D3,A1		;MAKE LOOKIN ADDRESS
POS040	MOVE.B	(A1)+,D0	;GET LOOKIN STR CHAR
	BEQ.S	POS080		;END OF LOOKIN, NF
	CMP.B	(A0),D0		;COMP TO LOOKFOR
	BNE.S	POS040		;TRY NEXT CHAR
	MOVE.L	A1,D3		;SAVE LOOKIN POINTER
	ADDQ.L	#1,A0		;INC LOOKFOR PNTR
POS060	MOVE.B	(A0)+,D0	;GET LOOKFOR CHAR 
	BEQ.S	POS070		;IF END, ITS FOUND
	CMP.B	(A1)+,D0	;CHECK FOR MATCH
	BNE.S	POS020		;NO GOOD,START OVER
	BRA.S	POS060		;KEEP LOOKING
POS070	SUBQ.L	#1,D3		;CORRECT POS FOUND
	MOVE.L	D3,(A4)		;PUT ON EVAL STACK
	RTS			;GO HOME
POS080	CLR.L	(A4)		;NOT FND, RTN NULL
	RTS
;--- FILL  ( #buf char siz -- )
FILL	MOVE.L	(A4)+,D0	;GET COUNT
	MOVE.L	(A4)+,D1	;CHAR
	MOVEA.L	(A4)+,A0	;BUFFER
FIL010	MOVE.B	D1,(A0)+
	SUBQ.L	#1,D0
	BNE	FIL010
	RTS
;--- MOVEC ( #from #to siz -- )
MOVEC	MOVE.L	(A4)+,D0	;GET COUNT
	MOVEA.L	(A4)+,A0	;DEST
	MOVEA.L	(A4)+,A1	;SOURCE
MOV020	MOVE.B	(A1)+,(A0)+
	SUBQ.L	#1,D0		;SLOWER THAN DBRA
	BNE	MOV020		;BUT BIGGER
	RTS
;--- CCOMP  ( #s1 #s2 bytes -- torf ) -- counted compare
CCOMP	MOVE.L	(A4)+,D1	;GET SIZE
	MOVEA.L	(A4)+,A0	; S1
	MOVEA.L	(A4)+,A1	; S2
	SUBQ.L	#1,D1		;CORRECT FOR DBRA
CCM100	CMPM.B	(A0)+,(A1)+	;COMPARE BYTES
	BNE.S	FALSE
	DBRA	D1,CCM100
TRUE	CLR.L	-(A4)		;SET RESULT TRUE
	NOT.L	(A4)
	RTS
FALSE	CLR.L	-(A4)		;SET RESULT FALSE
	RTS	
;---- SCOMP  ( #s1  #s2  -- torf )  -- string compare
SCOMP	MOVEA.L	(A4)+,A0	;#S2
	MOVEA.L	(A4)+,A1	;#S1
SCP000	MOVE.B	(A0)+,D0
	CMP.B	(A1)+,D0
	BNE	FALSE
	TST.B	D0		;SEE IF EOS
	BNE	SCP000
	BRA	TRUE
;---- DOUBLE INC  ( p1 p2 -- p1+1 p2+1 )
DBLINC	ADDQ.L	#1,(A4)
	ADDQ.L	#1,4(A4)
	RTS
;---- DOUBLE DEC  ( p1 p2 -- p1-1 p2-1 )
DBLDEC	SUBQ.L	#1,(A4)
	SUBQ.L	#1,4(A4)
	RTS
;---- MOVE BYTES RIGHT TO LEFT  ( src dest cnt -- )
MOVER	MOVE.L	(A4)+,D6	;COUNT
	MOVEA.L	(A4)+,A0	;DEST
	MOVEA.L	(A4)+,A1	;SOURCE
	ADDQ.L	#1,A0		;CORRECT FOR PRE DEC
	ADDQ.L	#1,A1
MVR000	MOVE.B	-(A1),-(A0)
	SUBQ.L	#1,D6		;ALLOW BIG COUNT
	BNE	MVR000
	RTS
******************************************
*          ARITHMETIC ROUTINES           *
******************************************
;--- MULTIPLY *
MULT	MOVE.W	2(A4),D0
	MULU	4(A4),D0	;B * C
	MOVE.W	(A4),D1
	MULU	6(A4),D1	;A * D
	ADD.L	D0,D1		;SUM
	SWAP	D1		;PUT IN LEFT
	CLR.W	D1		;CLEAR RIGHT
	MOVE.L	(A4)+,D0	;GET & MOVE PNTR
	MULU	2(A4),D0	;B * D
	ADD.L	D1,D0		;ADD HIGH PARTS
	MOVE.L	D0,(A4)		;PUT BACK
	RTS
;---- ROUTINE USED BY DIV AND MOD, SLOW BUT SMALL
DIVX	MOVE.L	(A4)+,D6	;GET DIVISOR
	MOVE.L	D6,D1		;COPY FOR SIGN
	BPL.S	DIV020		;OK IF +
	NEG.L	D6		;MAKE +
DIV020	MOVE.L	(A4),D5		;GET DIVIDEND
	MOVE.L	D5,D0		;COPY FOR SIGN
	BPL.S	DIV040		;OK IF +
	NEG.L	D5		;MAKE +
DIV040	MOVEQ	#0,D4		;CLEAR WORK
;------- DIVIDE 64 BITS BY 32 BITS D4:D5 / D6
DIV100	MOVEQ	#32,D3		;COUNT =32 BITS
DIV200	MOVE	#0,CCR		;CLEAR EXTEND
	CMP.L	D6,D4		;IF DVDND < DVSR
	BLO.S	DIV300		;NO ACTION
	SUB.L	D6,D4		;SUB DVSR
	MOVE	#$10,CCR	;SET QUOTIENT BIT
DIV300	ADDX.L	D5,D5		;SHFT LEFT DIVIDEND
	ADDX.L	D4,D4		;AND QUOT 64 BITS
	DBRA	D3,DIV200	;LOOP 32 TIMES
	RTS
;--- DIVIDE /
DIV	BSR	DIVX		;CRUNCH NUMBERS
	EOR.L	D0,D1		;SEE IF SIGNS ARE SAME
	BPL.S	DIV900		;IF PLUS, WERE SAME
	NEG.L	D5		;NEGATE QUOT
DIV900	MOVE.L	D5,(A4)		;SAVE QUOTIENT
	RTS
;---- REMAINDER MOD  
MOD	BSR	DIVX		;DO DIVISION
	LSR.L	#1,D4		;CORRECT REMAINDER
	TST.L	D0		;CHECK DIVIDEN SIGN
	BPL.S	MOD100		;PLUS NEEDS NO CHANGE
	NEG.L	D4		;NEGATE REM
MOD100	MOVE.L	D4,(A4)		;SAVE REM
	RTS
;---- */ MULT AND DIVIDE, 64 BIT IMTERMEDIATE
MDIV	MOVE.L	(A4)+,D6	;GET DIVISOR
	MOVE.L	D6,D2		;SAVE FOR SIGN
	BPL.S	MDV020		;OK IF +
	NEG.L	D6		;MAKE +
MDV020	TST.W	(A4)		;CHECK FACTOR
	BPL.S	MDV040
	NEG.L	(A4)		;MAKE +
	NOT.L	D2		;FIX SIGN
MDV040	TST.W	4(A4)		;CHECK OTHER FACTOR
	BPL.S	MDV060
	NEG.L	4(A4)		;MAKE +
	NOT.L	D2		;FIX SIGN
MDV060	MOVE.W	4(A4),D4	;CREATE 64 BIT PRODUCT
	MULU	(A4),D4		;HI * HI
	MOVE.W	2(A4),D5
	MULU	6(A4),D5	;LO * LO
	MOVE.W	(A4),D0
	MULU	6(A4),D0	;HA * LB
	MOVE.W	2(A4),D1
	MULU	4(A4),D1	;LB * HA
	ADD.L	D0,D1		;SET X BIT
	BCC.S	MDV100		;TAKE CARE OF CARRY
	ADDI.L	#$10000,D4	;IN HIGHEST WORD
MDV100	MOVE.L	D1,D0		;COPY
	SWAP	D0
	CLR.W	D0		;LOW HALF
	CLR.W	D1
	SWAP	D1
	ADD.L	D0,D5		;LOW 32 BITS
	ADDX.L	D1,D4		;HIGH 32 BIS
	BSR	DIV100		;DIVIDE IT
	ADDQ.L	#4,A4		;DROP AN ARG
	TST.L	D2		;CHECK THE SIGN
	BPL.S	MDV200		;OK IF +
	NEG.L	D5		;NEGATE IT, FORGET REM
MDV200	MOVE.L	D5,(A4)		;SAVE IT
	RTS			;GO HOME
;------ CHECK RANGE  ( item  low  high -- torf )
RANGE	MOVE.L	(A4)+,D0	;HIGH
	MOVE.L	(A4)+,D1	;LOW
	MOVE.L	(A4),D2		;ITEM
	CLR.L	(A4)		;ASSUME FALSE
	CMP.L	D1,D2		;COMP LOW
	BLT.S	RNG100		;GOTO FALSE
	CMP.L	D0,D2		;TEST HIGH
	BGT.S	RNG100		;GOTO FALSE
	NOT.L	(A4)		;RETURN TRUE
RNG100	RTS
******************************************
*             INPUT ROUTINES             *
******************************************
;--- GET A LINE FROM CONSOLE   (#buf max -- siz )
GETLIN	MOVE.L	(A4)+,D0		;GET MAX SIZE
	MOVE.L	(A4),PBLK1+10(A3)	;BUFADRS
	MOVE.W	#2,PBLK1(A3)		;CMD= READ
	MOVE.W	#1,PBLK1+4(A3)		;CHANNEL= 1 (CONSOLE)
	MOVE.W	D0,PBLK1+6(A3)		;MAX COUNT
	BSR	ATRAP			;SEND AND WAIT
	CLR.L	D0			;GET BYTES READ
	MOVE.W	PBLK1+8(A3),D0
	MOVE.L	D0,(A4)
	RTS				;BACK TO USER
;--- GET AN INTEGER FROM BUFFER (#buf siz -- int )
IGET	CLR.L	D0		;DEC PLACES
	BRA.S	DECBIN		;USE GENERAL INPUT
;--- GET A FLOATING VALUE FROM BUFFER (#buf siz decs -- fval )
FGET	MOVE.L	(A4)+,D0	;DEC PLACES
;---- GENERAL ASCII TO BINARY
DECBIN	MOVE.L	(A4)+,D1	;FIELD SIZE
	MOVEA.L	(A4),A0		;BUF POINTER
	CLR.L	D2		;START VALUE AT ZERO
	CLR.L	D4		;BEFORE DOT & +
	CLR.L	D5		;CLEAR WORK REG
DCB020	MOVE.B	(A0)+,D5	;GET CHAR
	CMPI.B	#' ',D5		;CHECK FOR SPACE
	BNE.S	DCB030
	SUBQ	#1,D1		;DEC FIELD SIZE
	BNZ	DCB020		;KEEP TRYING
	BRA	DCB999		;EXIT
DCB030	CMPI.B	#'-',D5		;CHECK FOR MINUS
	BNE.S	DCB040
	MOVE.B	D5,D4		;SAVE IN D4 HIGH
	SWAP	D4
	BRA.S	DCB200
DCB040	CMPI.B	#'+',D5		;CHECK FOR PLUS
	BEQ.S	DCB200		;IGNORE IT
;DCB050	SUBQ	#1,D1		;DEC FIELD SIZE
;	BEQ	DCB999		;IF 0, EXIT
DCB100	CMPI.B	#'0',D5		;CHECK LOW
	BLO.S	DCB120
	CMPI.B	#'9',D5		;CHECK HIGH
	BLS.S	DCB160
DCB120	CMPI.B	#'.',D5		;CHECK FOR DOT
	BNE	DCB220		;NON ZERO, MEANS DONE
	MOVE.B	D5,D4		;SET DOT FLAG
	TST.W	D0		;SEE IF INTEGER
	BEQ	DCB999		;IF SO, DONE
	BRA.S	DCB200		;TRY NEXT CHAR
DCB160	ANDI.L	#0FH,D5		;MAKE BINARY
	MOVE.L	D2,D3		;COPY VALUE
	LSL.L	#2,D2		;*4
	ADD.L	D3,D2		;*5
	LSL.L	#1,D2		;*10
	ADD.L	D5,D2		;ADD NEW
	TST.W	D4		;CHECK FOR AFTER DOT
	BEQ.S	DCB200
	SUBQ	#1,D0		;COUNT DEC PLACES
	BEQ.S	DCB260
DCB200	MOVE.B	(A0)+,D5	;GET NEXT BYTE
	SUBQ.W	#1,D1		;DEC FIELD SIZE
	BNE	DCB100		;PROCESS IT
DCB220	TST.W	D0		;SEE IF DEC PLACES DONE
	BEQ.S	DCB260
	MOVE.L	D2,D3		;COPY VALUE
	LSL.L	#2,D2		;*4
	ADD.L	D3,D2		;*5
	LSL.L	#1,D2		;*10
	SUBQ	#1,D0		;COUNT DEC PLACES
	BRA	DCB220
DCB260	SWAP	D4		;GET SIGN
	TST.W	D4		;SEE IF PLUS
	BEQ.S	DCB999
	NEG.L	D2		;NEGATE IT
DCB999	MOVE.L	D2,(A4)		;PUT ON STACK
	RTS
;--- GET NEXT CHAR FROM CONSOLE  ( -- ch )
GETC	LEA	NBUF(A3),A0		;USE NBUF
	MOVE.L	A0,PBLK1+10(A3)		;BUFADRS
	MOVE.W	#2,PBLK1(A3)		;CMD= READ
	CLR.W	PBLK1+2(A3)		;CLEAR STATUS FOR DEBUG
	MOVE.W	#1,PBLK1+4(A3)		;CHANNEL= 1 (CONSOLE)
	MOVE.W	#1,PBLK1+6(A3)		;MAX COUNT
	BSR	ATRAP			;SEND AND WAIT
	CLR.L	D0			;GET BYTE READ
	MOVE.B	NBUF(A3),D0
	MOVE.L	D0,-(A4)
	RTS				;BACK TO USER
******************************************
*           OUTPUT ROUTINES              *
******************************************
;--- PRINT AS INTEGER TO CONSOLE  ( val size -- )
IPRINT	MOVE.L	(A4)+,D6	;GET SIZE
	MOVE.L	(A4)+,D1	;GET VALUE
	BSR	CNVRT		;CONVERT IT
	BSR	SUPRES		;SUPRESS LEAD ZEROS
	MOVE.L	D6,D0		;SET COUNT TO WRITE
	LEA	IBUF(A3),A0	;POINT TO BUFFER
	LEA	0(A0,D6.W),A1	;END OF BUFFER
	SUBQ	#1,D6		;FIX FOR MOVE
	LEA	NBUF+11(A3),A2	;BUFFER
IPR110	MOVE.B	-(A2),-(A1)	;MOVE RIGHT TO LEFT
	DBRA	D6,IPR110	;LOOP UNTIL DONE
	BRA	APR100		;USE COMMON WRITE
;--- PRINT AS INTEGER  TO BUFFER  (buffer val size -- )
BIPRINT	MOVE.L	(A4)+,D6	;GET SIZE
	MOVE.L	(A4)+,D1	;GET VALUE
	BSR	CNVRT		;CONVERT IT
	BSR	SUPRES		;SUPRESS LEAD ZEROS
	MOVE.L	D6,D0		;SET COUNT TO WRITE
	MOVEA.L	(A4)+,A0	;POINT TO BUFFER
	LEA	0(A0,D6.W),A1	;END OF BUFFER
	SUBQ	#1,D6		;FIX FOR MOVE
	LEA	NBUF+11(A3),A2	;BUFFER
BPR110	MOVE.B	-(A2),-(A1)	;MOVE RIGHT TO LEFT
	DBRA	D6,BPR110	;LOOP UNTIL DONE
	RTS			;GO HOME
;--- PRINT AS PSEUDO FLOATING POINT TO CONSOLE ( val size dec -- )
FPRINT	MOVE.L	(A4)+,D5	;GET DEC POINT
	MOVE.L	(A4)+,D6	;GET SIZE
	MOVE.L	(A4)+,D1	;GET VALUE
	BSR	CNVRT		;CONVERT IT
	LEA	NBUF+12(A3),A1	;DEST
	LEA	NBUF+11(A3),A0	;SOURCE
	SUBQ.L	#1,D5		;FIX DEC FOR DBRA
FPR005	MOVE.B	-(A0),-(A1)	;SHIFT RIGHT
	DBRA	D5,FPR005
	MOVE.B	#'.',(A0)	;PUT IN DOT
	BSR	SUPRES		;SUPRESS LEAD ZEROS
	MOVE.L	D6,D0		;SET COUNT TO WRITE
	LEA	IBUF(A3),A0	;POINT TO BUFFER
	LEA	0(A0,D6),A1	;END OF BUFFER
	SUBQ	#1,D6		;FIX FOR MOVE
	LEA	NBUF+12(A3),A2	;BUFFER
FPR110	MOVE.B	-(A2),-(A1)	;MOVE RIGHT TO LEFT
	DBRA	D6,FPR110	;LOOP UNTIL DONE
	BRA	APR100		;USE COMMON WRITE
;--- PRINT AS PSEUDO FLOATING POINT TO BUFFER (buffer val size dec -- )
BFPRINT	MOVE.L	(A4)+,D5	;GET DEC POINT
	MOVE.L	(A4)+,D6	;GET SIZE
	MOVE.L	(A4)+,D1	;GET VALUE
	BSR	CNVRT		;CONVERT IT
	LEA	NBUF+12(A3),A1	;DEST
	LEA	NBUF+11(A3),A0	;SOURCE
	SUBQ.L	#1,D5		;FIX DEC FOR DBRA
BFPR05	MOVE.B	-(A0),-(A1)	;SHIFT RIGHT
	DBRA	D5,BFPR05
	MOVE.B	#'.',(A0)	;PUT IN DOT
	BSR	SUPRES		;SUPRESS LEAD ZEROS
	MOVE.L	D6,D0		;SET COUNT TO WRITE
	MOVEA.L	(A4)+,A0	;POINT TO BUFFER
	LEA	0(A0,D6),A1	;END OF BUFFER
	SUBQ	#1,D6		;FIX FOR MOVE
	LEA	NBUF+12(A3),A2	;BUFFER
BFPR11	MOVE.B	-(A2),-(A1)	;MOVE RIGHT TO LEFT
	DBRA	D6,BFPR11	;LOOP UNTIL DONE
	RTS
;--- PRINT A SINGLE BYTE
PUTC	MOVE.L	(A4)+,D0	;GET BYTE TO SEND
	LEA	NBUF(A3),A0	;USE NBUF
	MOVE.B	D0,(A0)		;PUT BYTE THERE
	MOVEQ	#1,D0		;COUNT=1
	BRA	APR100		;SEND IT
;--- PRINT A STRING ( adr -- )
SPRINT	MOVEA.L	(A4)+,A0	;GET START ADRS
	MOVE.L	A0,D0		;COPY IT
SPR005	TST.B	(A0)+		;SCAN FOR 0
	BNE	SPR005
	EXG	A0,D0		;EXCHANGE
	SUB.L	A0,D0		;SUBTRACT START
	SUBQ	#1,D0		;FIX FOR ()+
	BRA	APR100		;USE ARRAY PRINT
;--- PRINT AN ARRAY OF BYTES ( adr count -- )
APRINT	MOVE.L	(A4)+,D0	;GET COUNT
	MOVEA.L	(A4)+,A0	;GET START ADRS
APR100	MOVE.W	#3,PBLK1(A3)	;SET WRITE
	CLR.L	PBLK1+2(A3)	;CLEAR STATUS FOR DEBUG
	MOVE.W	#1,PBLK1+4(A3)	;SEND TO CONSOLE
	MOVE.W	D0,PBLK1+6(A3)	;BYTE COUNT
	MOVE.L	A0,PBLK1+10(A3)	;BUFFER ADDRESS
	BSR	ATRAP		;SEND IT
	RTS
;--- PRINT SPACES ( cnt -- )
SPACES	LEA	IBUF(A3),A0	;POINT TO BUFFER
	MOVEQ	#32,D1		;64 BYTE BUFFER
SPA010	MOVE.W	#'  ',(A0)+
	DBRA	D1,SPA010
	LEA	IBUF(A3),A0	;POINT TO SPACES
	MOVE.L	(A4)+,D0	;GET COUNT
	BRA	APR100		;USE ARRAY PRINT
;--- CONVERT BINARY TO ASCII - D1 HAS BINARY
CNVRT	MOVEQ	#20H,D7		;MAKE D7 A SPACE BYTE
	TST.L	D1		;FIX SIGN IN D7 HERE
	BPL	CNV005
	MOVEQ	#'-',D7		;MAKE SIGN '-'
	NEG.L	D1		;NEGATE NUMBER
CNV005	MOVEQ	#8,D3		;COUNT FOR 10 DIGITS
	LEA	NTABL(A3),A1	;CONVERSION TABLE
	LEA	NBUF(A3),A0	;OUTPUT BUFFER
	MOVE.B	#020H,(A0)+	;START WITH SPACE
CNV010	MOVE.L	(A1)+,D2	;GET CONVERSION FCTR
	MOVEQ	#-1,D0		;CORRECT FOR ADD BACK
CNV020	ADDQ	#1,D0		;COUNT DIGIT
	SUB.L	D2,D1		;SUB POSITION
	BGE	CNV020		;IF >=0 KEEP GOING
	ADD.L	D2,D1		;ADD BACK FINAL
	ORI.B	#030H,D0	;MAKE ASCII
	MOVE.B	D0,(A0)+	;STORE IT
	DBRA	D3,CNV010	;GET NEXT DIGIT
	ORI.B	#030H,D1	;UNITS DIGIT
	MOVE.B	D1,(A0)		;POINT TO RIGHT DIGIT
	RTS			;ALL DONE
;---- SUPRESS ZERO IN OUTPUT
SUPRES	LEA	NBUF+1(A3),A0
	MOVEQ	#8,D3
SUP001	CMPI.B	#'0',(A0)	;SCAN FOR NON 0
	BNE	SUP002
	MOVE.B	#' ',(A0)+	;REPLACE WITH SPACE
	DBRA	D3,SUP001	;DO 9 DIGITS
SUP002	MOVE.B	D7,-(A0)	;BACK UP FOR SIGN
	RTS
;---- CONSTANT TABLE FOR NUMBER CONVERSION
NTABL	DC.L	1000000000,100000000
	DC.L	10000000,1000000
	DC.L	100000,10000
	DC.L	1000,100
	DC.L	10
NBUF	DC.W	0,0,0,0,0,0	;DIGIT BUFER
IBUF	DC.L	0,0,0,0,0,0,0,0
	DC.L	0,0,0,0,0,0,0,0
******************************************
*          GENERAL OS ROUTINES           *
******************************************
; TERMINATE PROGRAM -- TERMINATE CODE ON EVAL STACK
EXIT	LEA	PBLK1(A3),A0	;POINT TO PARAM BLK
	MOVE.W	#54,(A0)	;FUNCTION #54
	CLR.W	2(A0)		;STATUS
	MOVE.L	(A4)+,4(A0)	;TERMINATE CODE
	BRA	ATRAP		;GO DO IT
;--- CHAIN TO AND START AN OVERLAY ( adr -- )
CHAIN
;--- TRAP AND WAIT FOR RESULT
TRAP	MOVEA.L	(A4)+,A0	;POINT TO PARAMS
	TRAP	#1		;SENT TO OS
TRP001	TST	2(A0)		;CHECK FOR DONE
	BPL	TRP001		;LOOP UNTIL MINUS
	RTS			;GO BACK
;--- TRAP USED BY RTL
ATRAP	LEA	PBLK1(A3),A0	;ALWAYS USE THIS
	TRAP	#1
ATR020	TST.W	2(A0)		;WAIT FOR DONE
	BPL	ATR020
	RTS
;----------- VERSION WITH WAITING 0
;ATRAP	LEA	PBLK1(A3),A0	;ACTION
;	LEA	PBLK2(A3),A1	;WAIT0
;	TRAP	#1		;SEND TO OS
;ATR020	TST.W	2(A0)		;SEE IF DONE
;	BMI.S	ATR030		;IF DONE, LEAVE
;	EXG	A0,A1		;SWAP PARAMS
;	TRAP	#1		;FORFIT TIME
;	EXG	A0,A1		;BACK TO ACTION
;	BRA	ATR020		;TEST AGAIN
;ATR030	RTS			;ALL DONE
******************************************
PBLK1	DC.W	0,0,0,0,0,0,0,0	;PARAM BLOCK #1
PBLK2	DC.W	0,0,0,0,0,0,0,0	;PARAM BLOCK #2
STKSAV	DC.L	0		;PLACE TO SAVE STACKPN
HEAPS	DC.L	0		;START OF HEAP
HEAPL	DC.L	0		;CURRENT HEAP POINTER
RTEND	EQU	$		;SIZE OF RTL
	END
