;;; Copyright (c) 2021-2022 Ufasoft  http://ufasoft.com  mailto:support@ufasoft.com,  Sergey Pavlov  mailto:dev@ufasoft.com
;;;
;;; SPDX-License-Identifier: MIT


;;; Lisp interpreter for BK-0010.01
;;; Version 2022
;;;
;;; Implements subset of COMMON LISP
;;; Uses Vilnus BASIC 1985 ROM (firmware 106, 107, 108)
;;;
;;; https://ufasoft.com/bklisp
;;;


.TITLE	bklisp

.SBTTL	Main module

.INCLUDE /macros.inc/



SY.PREV=0


.ASECT

.GLOBL	START2
.GLOBL	A.END, A.PREV, HEAPFR, STDIN
.GLOBL	V.BIFU, V.ERR, V.FLT, V.FREQ, V.FUN, V.FUNC, V.GCNT, V.GO, V.BLOCK, V.IF, V.UNLESS, V.INT, V.LAMB, V.LAST, V.LET
.GLOBL	V.LETA, V.LIST, V.NULL, V.OPT, V.PBAS, V.PESC, V.PPP, V.PRAD, V.PROG, V.QUOT, V.REST, V.RNDS, V.FILE, V.S, V.SETF, V.SETQ
.GLOBL	V.SPEC, V.SPOP, V.STDI, V.STM, V.STR, V.CONS, V.SYM, V.SYVA, V.T, V.TAGB, V.CHAR, V.VEC, V.PSETQ, V.QUIT

.IF NE C$FULL
	.GLOBL	 V.KEYW, V.TRC, L.TRAC, KW.DIR, KW.OUT
.ENDC

.IF NE C$BK10
	.GLOBL	GCRET
.ENDC

.IIF NE C$MVAL,		.GLOBL	 V.D
.IIF NE C$MDAR, 	.GLOBL	 V.AR
.IIF NE C$RT11,		.GLOBL	 V.ARGS

.IF NE C$RT11
.	= 34
	.WORD	I.TRAP, 0		; don't mask interrupts for TRAP

.	= $USRSP
	.WORD	ASTKUP
.	= $JSW
	.WORD	TTLC$ + CHNIF$ 	; Disables automatic conversion of to uppercase characters. Pass empty Command Line to KMON

	. = 300
LSTTIM:	.WORD	0, 0		; to detect roll over 24h
TIMADD:	.WORD	0, 0		; ticks per day if rolled over 24h
	.EVEN
;;------ Must be adjacent. Used in RENAME-FILE
AREA::	.BLKW	5
$BUFOUT::.BLKB	24.		; Output buffer
	$TMPFN	= $BUFOUT+9.	; Temporary buffer for ASCII filename
;;-----------------------

	. = 1000
START3:	JMP	@#START2
.INCLUDE /init.mac/

	. = ASTKUP
.IFF
	.IIF NE C$BK10	.	= 756
	;.IIF	NE C$BK11	.	= ASTKUP - 100. - 24	; Reserve 100. bytes as space for init code

	.IF NE C$BK11
. = 360
$BUFOUT::.BLKB	24.		; Output buffer

		.  = ASTKUP - 4
		.WORD	ASTKUP					; Loader header: Start address
	.IFF
		.WORD	RETADR
	.ENDC ; C$BK11

	.WORD	A.END - RETADR					; Loader header: Image size

RETADR:	BR	START						; in case if autorun does not work (loaded on BK-0011)
	.WORD	START, START, START, START, START, START	; return addresses for auto-run, don't use label becase this code is relocatable
START:
	.IF NE C$BK11
	;; Move code above stack space
;		MOV	#A.END - <ASTKUP - 1000>, R1
;	1$:	MOV	-(R1), ASTKUP - 1000(R1)
;		CMP	R1, PC
;		BNE	1$
	.ENDC	; C$BK11
START3:	JMP	@#START2

.ENDC ; C$RT11


;.IIF EQ C$BK10	.INCLUDE /init.mac/

.	= ASTKUP

;; Roots (order does matter), used in PLACE
ROOTS:
;; vars cleared in RESET
A.ROOT:
LEXENV:	.WORD	0		; Lexical Environment
DYNENV:	.WORD 	0		; Dynamic Environment
.IIF NE C$FULL,	INDENT:	.BYTE	0
.EVEN
ERDATA:	.WORD 	0		; Error message data
CATCH:	.WORD	0		; Stack pointer to catch errors
C.ROOT:

PRVTIM:	.WORD	V.0			; Last timestamp returned by (GET-INTERNAL-REAL-TIME)
;;------ order does matter, used in INTERN
OBLIST:	.WORD 	V.LAST
.IF NE C$FULL
KWLIST:	.WORD 	KW.OUT
;;------
;;-- Order does matter, used in TRACE
TRACLS:	.WORD	0			; A-List of traced symbols and original functions
	.WORD	L.TRAC			; Macro for tracers
.ENDC
.IIF NE C$MVAL,	MVAL:	.WORD	1		; FIXNUM means result in R1, else MVAL is value list
.IIF NE C$FULL,	REPLLS:	.WORD	A.PREV-4	; Special vars used by REPL
E.ROOT:



.INCLUDE /gc.mac/	; Put GC code before SUBRs to give more space for FIXNUM values



.IIF NE C$BK11	I.STOP::
H.STOP:	MOV	#$WSTOP, R1	; Handler of STOP key
I.STO2:
.IF NE C$BK10
	MOV	#$WSTOP+6, R2
	SUB	R1, R2
.IFF
	MOV	R1, R0
.ENDC ; C$BK10
	MOV	#ASTKUP, SP

.IF NE C$RT11
	.PRINT
.IFF
M.PRN::	EMT	20
.ENDC ; C$RT11

RESET::


.IF EQ C$GTLI ! <C$RT11 - 1>	; RT-11 with .GTLIN-less mode
	CLR	INCUR		; flush input
	CLR	INEND		; flush input
.ENDC ; C$BK10

REPL:   MOV	#C.ROOT-A.ROOT, R2
1$:	CLRB	A.ROOT-1(R2)	; Clear LEXENV, DYNENV, ERDATA, INDENT
	SOB	R2, 1$		; R2: 0  is *STANDARD-INPUT*, used also in .CONS
	CLR	R0		; R0: 0 to avoid reverence into the Heap in the Stack
	.P.CHR	C.NL
.IF NE C$GTLI & C$RT11
	MOV	#LPROM, PROMPT
.IFF
	.P.CHR	'>, C.SP
.ENDC ; C$GTLI & C$RT11

	.$READ
.IF NE C$FULL

	MOV	R1, R2
	.IF NE C$RT11
;	CLR	R1
;	TO.STM
;	MOVB	#C.NL, 5(R1)	; to avoid LF in FRESH-LINE
	.ENDC	; C$RT11
	MOV	#V.S, R1	; '-' Symbol
	.SET			; (SETQ - form); R1: read form
.ENDC ; C$FULL

.IIF NE C$BK11	CLR	$SYREG	; Enable STOP key
	; CALL	EVAL		; Don't use .EVAL to save stack space in every evaluation
	.EVAL1
	.PRED	FRESHT		; (FRESHLINE NIL)
.IF NE C$FULL
	MOV	R1, R2
	MOV	#V.PPP, R1
	.SET			; (SETQ +++ value)  to be rotated into *; R1: evaluated value
	CLR	R2
.ENDC ; C$FULL
.IF NE C$MVAL
	MOV	MVAL, R5
	BEQ	2$
	CMP	R5, SP
	BHI	2$		; values in R5
	.CONS			; R1: values
	MOV	R1, R5
2$:	MOV	R5, R2
	MOV	#V.MMM, R1
	.SET			; (SET '*** R5) to be rotated into /
	CLR	R2		; R2: stdout
	.POP5
	BEQ	5$
	CALL	PRINT1		;   .PRIN1;  .P.CHR C.SP
	BR	4$
3$:	.P.CHR	C.SEMI
	.PRNT
4$:	.POP5
	BNE	3$
5$:

.IFF
	.PRIN1			; Print evaluated value
.ENDC	; C$MVAL
.IF NE C$FULL
	MOV	#A.PREV-4, R5
	.SUBR	ROTATEF		; (ROTATEF - /// // / *** ** * +++ ++ +)
.ENDC
	BR	REPL

;;-- 12. words on BK-0010
LOADER::
	CLR	R1
	CLR	(R1)+
	CLR	(R1)+			; Init NIL
.IF NE C$RT11
	MOV	#14, R1
	CMP	(R1)+, (R1)+
.IFF
	MOV	#I.STOP, (R1)+		; Init STOP key vector 4
	CLR	(R1)+
	MOV	#I.PCHR, 10
	CLR	(R1)+
.ENDC	;  C$RT11
	MOV	#M.PUSH, (R1)+		; vector 14
	MOV	#340, (R1)+
 	MOV	#M.BIT, (R1)+		; vector  20

.IF NE C$RT11
	.SETTOP	$SYPTR		; Allocate max space. R0: max address
	MOV	R0, R2		; R0, R2: max address
	SUB	#HEAP, R0
	CLR	R1
7$:	INC2	R1
	SUB	#66., R0
	BHI	7$
	MOV	R1, GCBMSZ	; GCBMSZ: Heap size / 32, even
	SUB	R1, R2
	BIC	#3, R2
	MOV	R2, EHEAP

	.TRPSET	#AREA, #TRPLOC
	.SCCA	#AREA, #SCCA
	MOV	#I.PCHR, 10	; vector 10. Assign after .TRPSET to override
	.PRED	PARSCL		; Parse Command Line
.IFF
	MOV	#I.TRAP, @#34
	;	CLR	@#36

	MOV	#ASTKUP, SP
.ENDC	; C$RT11

	MOV	(PC)+, R1
A.MAIN:	.WORD	0
	BEQ	RESET
	CLR	R5
	CALL	FUNCALL
.IIF NE C$RT11,	.PRED	QUIT
.IIF EQ C$RT11,	.EXIT

;; Negate FLT4 on Stack
DNEG:	MOV	#100000, R5
	XOR	R5, (SP)
	JMP	@(R4)+



.IF NE C$BK10
.	= $III		; 2060
	.BLKW 4		; USED BY $RAN
.	= $RNDSAV	; 2070
	.BLKW 4

I.STOP::
	MOV	GCRET, R1
	BEQ	H.STOP		; GC is not in progress?
       	MOV	#H.STOP, GCRET	; Defer STOP handling to end of GC
       	RTI
P.ERR:	MOV	#$ERROR, R1
	MOV	#8., R2
	EMT	20
	RETURN

.	= $SAVJMP	; 2134
	.WORD		0
.ENDC	; C$BK10

;;-- 90 words

;; Throw error if R1 is not function name: SYMBOL os (SETF SYMBOL)
;; Returns  true if R1 - symbol
FUNAMP:	.SYMP
	BCS.T
	CMP	(R1)+, #V.SETF
	BNE.E
	MOV	(R1), R1
	.POP1
	BEQ.E			; check (SETF symbol)
	RETURN


DOPREP:	POP	R3		; SP is caller's SP
	CALL	BLENV0		; (BLOCK NIL ...
	PUSH	R3
	PUSH	R5		; Save Body
	MOV	R1, R5
	.POP5			; R1: var
	.CONS
	MOV	R1, R3
	TST	(R3)+
	MOV	LEXENV, R2
	.CONS
	MOV	R1, R0
	.POP5			; R1: list-for/count-form
	.EVAL1
	MOV	R0, LEXENV	; SET ENVIRONMENT
	MOV	(R5), R4	; R4: result-form
	POP	R5
	RETURN



;;;--- Threaded code subroutines

;;; FORTH Stack operations



;; Push PI/2
PUPID2:	MOV	#$PIDV2 + 10, R1
	BR	DDUP1

;; Duplicate FLT4 on STACK
DDUP:	MOV	#10, R1
DDUP0:	ADD	SP, R1
DDUP1:	JMP	$PUSH8


;; Swap two FLT4 on Stack
;; Implementation:   DTUCK DDROP
DSWAP:	.BASIC	DTUCK
DDROP:	ADD	#10, SP
R.R4:	JMP	@(R4)+

;; Push INTERNAL-TIME-UNITS-PER-SECOND as FLT4
DPFREQ:	.SYVAL	V.FREQ
	BR	DPUFL1

;; Push R1, R2 as FLT4; swap(R1, R2)
DPUR12:	PU.FL
DPUR2:	.SWP12
	BR	DPUFL1

;; Push immediate (R4)+ as FLT4
DPUFL:	MOV	(R4)+, R1
DPUFL1:	PU.FL
	JMP	@(R4)+

;; Stack: x y  =>  y x y
DOVER:	MOV	#20, R1
	BR	DDUP0


.IF NE C$FULL

;; IN: Stack: divisible;  (R4): divider
;; OUT: Stack: quotient, reminder
DIVREM:	MOV	(R4)+, R1	; R1: divider
	PU.FL

	MOV	R4, DIVRR4	; Save R4
	.BASN
	.WORD	DOVER, DOVER, $DDIV, $INT, DTUCK2, $DMUL, $DSUB, DSWAP, 1$			;!!!TODO use FLOOR
1$:	MOV	(PC)+, R4
DIVRR4:	.WORD	0		; restore R4
	JMP	@(R4)+

;; Input:  R2: package-designator. NIL or V.U for "CL", V.KEYW for "KEYWORD"
;; Output: R2: #OBLIST or #KWLIST
GEOBLS:	CMP	R2, #V.KEYW
	BEQ	1$
	MOV	#OBLIST - KWLIST + V.KEYW, R2
1$:	ADD	#KWLIST - V.KEYW, R2
	RETURN

.ENDC ; C$FULL

;; Stack: x y z  =>   x y z x
DTUCK2:	MOV	#14, R1
	BR	DTUCKC

;; Stack: x y  =>   x y x
DTUCK:  MOV	#10, R1
DTUCKC:	MOV	SP, R2
	SUB	#10, SP
	MOV	SP, R3
1$:	MOV	(R2)+, (R3)+
	SOB	R1, 1$
	MOV	SP, R2
	BR	DCP23


;; Copy $III, $RNDSAV into random-state
B.III:	MOV	#$III, R2
	MOV	(PC)+, R3
A.RDNS:	.WORD	0
DCP13:	CALL	COPY4
	MOV	(PC)+, R3
B.RDNS:	.WORD	0
DCP23:	CALL	COPY4
	JMP	@(R4)+



.IF NE C$BK10
.	= $BUF-2	; 2422
	.WORD	0	; used by GENSYM
.	= $BUF
	.BLKB	400	; used by IVEIL to read line

.	= $BUFOUT	; 3022
	.BLKB	24.	; used by BASIC $UNPCK
E.SYS:			; End address of system area
.ENDC	; C$BK10


ASUBRT:	.WORD	ASUBR1, ASUBR2, ASUBR3			; , ASUBR4
FSUBRT:	.WORD	FSUBR1, FSUBR2, FSUBR3, E.FSUBR



.IF NE C$RAD40
	.INCLUDE /rad40.mac/
	.IIF NE C$FILE, .INCLUDE /rad50.mac/
.IFF
	.INCLUDE /rad50.mac/
.ENDC

.IF NE C$MDAR

.IF NE 0	; COMMENT OUT  TEMPORARY!!!
;; R1: list of FIXNUM dimensions
;; Returns R1: product as UINT
MULDIM:	MOV	#1, R5
	BR	3$
1$:	MOV	R5, R4
	CLR	R5
2$:	ADD	R4, R5
	SOB	R0, 2$
3$:	.POP1
	BEQ	9$
	SUB	#V.0, R0
	BNE	1$		; non-zero multiplier
	CLR	R5
9$:	MOV	R5, R1		; product
	RETURN
.ENDC		; COMMENT OUT  TEMPORARY!!!

.ENDC	; C$MDAR


.IF NE C$RT11
$ERROR::
	.ASCII	/ ERROR /<C.BEL><200>
	.BYTE	0, 0, 0			; some space for localization
	.EVEN
P.ERR:	.PRINT	#$ERROR
	RETURN
.ENDC ; C$RT11

.IF NE C$BK11
$ERROR: .ASCII	<C.CY.O><C.CY.W><C.CY.I><C.CY.B><C.CY.K><C.CY.A>/ /<C.BEL><200>		; 'ERROR' in russian
	.EVEN
P.ERR:	MOV	#$ERROR, R0
	.PRINT
	RETURN
.ENDC ; C$BK11



;; Return: true if char is constituent
CSTITP:	MOV	#E.TER - TERM, R3
1$:	CMPB	R1, TERM-1(R3)
	BEQ.F
	SOB	R3, 1$
	BICB	#200, R1
	CMPB	#37, R1
	B.CF

;; Find place in property-list
;; Input: R1: symbol, R2: property-indicater
;; Returns: R5: (pointer to place)+2, R4: pointer to current list item; ZF=1, R5=0 if not found
PLSPLC: T.SYM
.IIF EQ C$VM1,	DEC	R1
PLSPL4:	MOV	R1, R5
PLSPL2:	MOV	R5, R4		; R4: &tail
	MOV	(R4), R5	; R5: Property-list
;; Assume ZF: R5==0
PLSPL1:	BEQ	9$
	MOV	(R5)+, R0	; R0: property name
	MOV	(R5), R5
	TST	(R5)+		; R5: &tail
	CMP	R0, R2
	BNE	PLSPL2        	; continue search
	CLZ
9$:	RETURN


.IF NE C$BK10
;; Prepare filename argument for File API
;; R1: filename as STRING object
PSNAME: MOV	#15, R4		; #words of param block segment
1$:	PUSH	#20040		; Spaces
	SOB	R4, 1$
	MOV	SP, R4
	T.STR
	SUB	#3, R1
	MOVB	(R1)+, R2	; filename length
	BIC	#177760, R2	; limit length by 16. chars, but really need 12.
2$:	MOVB	(R1)+, (R4)+
	SOB	R2, 2$
	JMP	(R5)
.ENDC	; C$BK10


.IIF EQ C$BK10	.INCLUDE /math.mac/

.IF NE C$GTLI & C$RT11

$IVEIL:	MOV	#$BUF, R1
	.GTLIN	R1, PROMPT
	CLR	(PC)+
PROMPT:	.WORD	0
1$:	TSTB	(R1)+
	BNE	1$
	MOVB	#C.NL, -1(R1)
	RETURN
LPROM:	.ASCII	/> /<200>	; prompt

.ENDC ; C$GTLI & C$RT11


.IF NE C$RT11
;; Days per month
DAYMON:	.BYTE	0, 31.
FEBRUA:	.BYTE	28.
	.BYTE	31., 30., 31., 30., 31., 31., 30., 31., 30. ;, 31.
.ENDC ; C$RT11

.IF NE C$RAD40
	R40TAB:	.ASCII	/*-+12/
	.IIF NE C$FILE,	R50TAB:	.ASCII	/*-=0123456789/
.IFF
	R50TAB:	.ASCII	/*-=0123456789/
.ENDC

.IF EQ C$BK10
	$WSTOP::
		.ASCII	<C.NL>/BREAK/
	$WNL::	.ASCIZ	<C.NL>
.ENDC ; C$BK10

TERM:	.ASCII	<C.SEMI>/()"'`, /
E.TER:	.EVEN

PESC:	.SYVAL	V.PESC		; R1: *PRINT-ESCAPE*
	RETURN

.IF NE C$BK11

$IVEIL:	MOV	#$BUF, R5
1$:	CMP	R5, #$BUF + 377
	BHIS	9$
	.BTTIN
	MOV	R0, R1
	.CCASE
2$:	.WORD	7$-2$-2/2
	.SBYTE	C.NL, <12$-2$/2>
	.SBYTE	$K.BS, <6$-2$/2>	; Backspace
	.SBYTE	$K.BC, <3$-2$/2>
	.SBYTE	$K.LE, <13$-2$/2>	; Left
	.SBYTE	$K.RI, <14$-2$/2>	; Right
7$:	MOVB	R1, (R5)+
	.BTOUT
	TST	BCALLW
	BEQ	1$
	CLR	BCALLW
	MOV	#376, R4
11$:	CLRB	$BUF(R4)
	SOB	R4, 11$
	BR	1$
12$:	.BTOUT	#C.CR
	.BTOUT	#C.NL
16$:	TSTB	(R5)+
	BNE	16$
	MOVB	R1, -1(R5)	; NewLine
	BR	10$
6$:	CMP	R5, #$BUF
	BLOS	1$
	DEC	R5
	MOV	R5, R4
8$:	MOVB	1(R4), (R4)+
	BNE	8$
	.BTOUT	#33		; ESC D
	.BTOUT	#104
	.BTOUT	#33		; ESC P
	.BTOUT	#120
	BR	1$
13$:	CMP	R5, #$BUF
	BLOS	1$
	DEC	R5
	.BTOUT
	BR	1$
14$:	CMP	R5, #$BUF + 377
	BHIS	1$
	INC	R5
	.BTOUT	#33		; ESC C
	.BTOUT	#103
	BR	1$

3$:	TST	BCALLW
	BEQ	1$
4$:	TSTB	(R5)+		; BC
	BNE	4$
	DEC	R5
	CMPB	-1(R5), #C.NL
	BNE	5$
	CLRB	-(R5)
5$:	.BTOUT	#33		; ESC R
	.BTOUT	#122
	.BTOUT	#33		; ESC K
	.BTOUT	#113

	MOV	#$BUF, R0
	MOV	R5, R1
	SUB	R0, R1
	.BEDIT
	MOV	#$BUF, R5
	MOV	#C.NL, R1
	BR	12$
9$:	CLRB	(R5)
10$:	MOV	R5, (PC)+
;; BS key is allowed
BCALLW:	.WORD	1
	MOV	R5, R1
	RETURN

.ENDC ; C$BK11


.IF NE C$RT11

;; Parse Command Line into *ARGS* variable
;; Returns R1: *ARGS*
PARSCL::
	MOV	#$CLLEN, R3
	MOV	(R3), R5	; R5: command line length
	MOV	#1, (R3)+
	.SUBR	MKSOS
	MOV	R1, R2		; R2: (MAKE-STRING-OUTPUT-STREAM)
3$:	DEC	R5
	BMI	5$
	MOVB	(R3)+, R1
4$:	CMPB	R1, #C.SP
	BLOS	5$		; arg terminator
	.PRED	W.CH2		; (WRITE-CHAR R1 R2)
	BR	3$
5$:	MOV	R2, R1
	.SUBR	GETOSS		; (GET-OUTPUT-STREAM-STRING R2)
	TSTB	-3(R1)
	BEQ	7$		; ignore empty argument
	.PUSH0
7$:	TST	R5
	BPL	3$
	MOV	#V.ARGS, R1
	.GPLAC
	.NREV0

	MOV	#64., R2
8$:	CLRB	$CLBUF-1(R2)		; Clear command line
	SOB	R2, 8$

	MOV	R1, (R4)	; (SETQ *ARGS* (command-line args))
	RETURN


;; Get filespec in RADIX-50
R50FN:	.SUBR	STRUP		; (STRING-UPCASE filespec)
	MOV	R1, R3
	DEC2	R3		; R3: begin of filename
	.LENGTH
	TO.U16
	ADD	R3, R1		; R1: end of filename

	MOV	#$TMPFN.+13., R2	; temp buf
	MOV	#12., R5
	MOVB	R5, $TMPFN
1$:	MOVB	#C.SP, -(R2)   	; init temp buf with spaces
	SOB	R5, 1$

;; Prepare filename
	MOV	R3, R4		; R4: begin of filespec
	MOV	#"DK, (R2)+	; default device is DK:
    	MOVB	(R2), R0
5$:	MOVB	R0, (R2)+
4$:	CMP	R3, R1
	BHIS	6$		; End of string
	MOVB	(R3)+, R0
	CMPB	R0, #':
	BEQ	7$		; Copy Device name
	CMPB	R0, #'.
	BNE	5$
	MOV	#$TMPFN+1+9., R2	; Jump to filename extension part
	BR	4$

7$:	MOV	#$TMPFN+1, R2	; R2: pointer to device part
	MOV	#3, R5
8$:	MOVB	(R4)+, R0
	CMP	R4, R3
	BLO	2$
	MOVB	#C.SP, R0
2$:	MOV	R0, (R2)+
	SOB	R5, 8$
	BR	4$		; R2: pointer to filename part

6$:	MOV	#$TMPFN+3, R1
	CALL	A2R50		; Convert filename to RADIX-50
	BCS.E			; Incorrect filename
R50FN1:	SEC
R50FN9:	RETURN

;; Read/Write block
;; 	R1: position
;; 	R3: high byte: operation code: S$REA for Read; S$WRI for Write
;; 	R4: buffer
;; OUTPUT:
;;   CF=1:  EOF
;; Saves R2, R5
REAWRI:	MOV	#AREA+10, R0
	CLR	(R0)
	MOV	#256., -(R0)
	MOV	R4, -(R0)
	MOV	R1, -(R0)
	SWAB	(R0)
	ASR	(R0)
	BIC	#^C177, (R0)	; (R0): block number
	MOV	R3, -(R0)
	MOVB	-4(R4), (R0)	; (R0): `operation code`|channel
	EMT	375
	BCC	R50FN9		; RETURN
	CMP	R3, #S$WRI * 256.
	BEQ	7$		; Write case
	TSTB	$ERRBY
	BEQ	R50FN1		; SEC; RETURN
7$:	JMP	EIO1

;; Decode RT-11 date representation from R5 into (day month year) list in R0
DECDMY:	CLR	R0
	MOV	R5, R1
	BIC	#^C37, R1
	MOV	R5, R2
	SWAB	R2
	BIC	#^C300, R2
	ASR	R2
	BIS	R2, R1
	ADD	#1972. + FIXOFF, R1	; R1: year
	.PUSH0
	MOV	R5, R1
	SWAB	R1
	ASR	R1
	ASR	R1
	BIC	#^C17, R1       	; R1: month
	F.U16
	.PUSH0
	MOV	R5, R1
	ASL	R1
	ASL	R1
	ASL	R1
	SWAB	R1
	BIC	#^C37, R1
	F.U16				; R1: day
	.PUSH0                          ; R0: (day month year)
	RETURN

.ENDC ; C$RT11

.INCLUDE /trap.mac/

FIXEND::
.INCLUDE /subr.mac/
.INCLUDE /fsubr.mac/

;; EHEAP::	.WORD	HIMEM 	; same as $ANVP

ALGN4
A.LTYP:	.ASCIP	<Ufasoft BkLisp>

ALGN4
A.LVER:	.ASCIP	<2023.2>

ALGN4
A.MTYP:	.ASCIP	<PDP-11>

.IF NE C$RT11
ALGN4
A.SVER:	.ASCIP	<5.0>
ALGN4
A.STYP:	.ASCIP	<RT-11>
.ENDC

;;------Order does matter: ROOM uses zero from FREEL-2 word
ALGN4
A.EMPTY:.ASCII	<0>
.EVEN
FREEL:	.WORD	HEAPFRE
;;;----

ALGN4
A.NIL:	.ASCIP	<NIL>

ALGN4
A.MVER::
	.BYTE	E.MVER - . - 1		; length byte
.IIF NE C$BK10	.ASCII	<C.CY.B><C.CY.K>/-0010.01/
.IIF NE C$BK11	.ASCII	<C.CY.B><C.CY.K>/-0011/<C.CY.M>
.IIF NE C$RT11	.ASCII	/LSI-11/<0><0><0>				; space for localization
E.MVER:

;;----Order does matter. Used by NAME-CHAR
ALGN4
A.SPAC:	.ASCIP	<SPACE>

ALGN4
A.RETU:	.ASCIP	<RETURN>

ALGN4
A.NEWL:	.ASCIP	<NEWLINE>

ALGN4
A.TAB:	.ASCIP	<TAB>
;;------------


ALGN4
A.ROOM: .ASCII	<11.>/Bytes free/<C.NL>

ALGN4
A.GSYM: .ASCIP	<~A~A>			; used by GENSYM

VS.NIL	= A.NIL + 3
V.EMPTY	= A.EMPTY + 3
V.MTYP	= A.MTYP + 3
V.MVER	= A.MVER + 3
V.LTYP	= A.LTYP + 3
V.LVER	= A.LVER + 3
V.GSYM 	= A.GSYM + 3

.IF NE C$RT11
V.STYP	= A.STYP + 3
V.SVER	= A.SVER + 3
.ENDC


.IF NE C$FULL

ALGN4
A.TRCA:
.IIF NE C$RT11, .ASCII	<3>/<- /
.IIF EQ C$RT11, .ASCII	<2><C.LE>/ /

ALGN4
A.TRCR:
.IIF NE C$RT11, .ASCII	<3>/-> /
.IIF EQ C$RT11, .ASCII	<2><C.RI>/ /

.ENDC ; C$FULL


ALGN4
TOKLEN:	.BYTE	0
TOKBUF:	.BLKB	MAXTOK


ALGN4
F32768:	.FLT4	32768.
.IIF NE C$RT11	F65536:	.FLT4	65536.


.IF EQ C$BK10

TWODPI:	.FLT4	.63661977236758134307553505349	 ; 2/PI

;; Constants used in the approximation
LN2:	.FLT4	.6931471805599453094172321
LN2IN:	.FLT4	1.44269504088896	; 1/LN(2)

;; Constants used by square root routine
SQRT0:	.FLT4	0.41730759
SQRT1:	.FLT4	0.59016206
SQRT2:	.FLT4	1.41421356237309504880 ; SQR(2)

;; Coefficients used to approximate SIN/COS functions
C0:	.FLT4	0.15707963267948966188272E1

	.FLT4	-0.64596409750624619108547
	.FLT4	 0.7969262624616543562977E-1
	.FLT4	-0.468175413530264260121E-2
	.FLT4	 0.1604411847068220716E-3
	.FLT4	-0.359884300720869272E-5
	.FLT4	 0.5692134872719023E-7
	.FLT4	-0.66843217206396E-9
	.FLT4	 0.587061098171E-11
SCTAB:	.WORD	8.			; order of polynomial


$III::	.BLKW	4	; Working Area of RND
$RNDSAV::
	.BLKW	4	; Current value of RND
.ENDC ; EQ C$BK10

.IIF NE C$BK11 $BUF::	.BLKB	400	; Input buffer
.IIF NE C$RT11 $BUF::	.BLKB	81.	; Line Input buffer


E.CODE:
.IF DF HEAP
	.IIF GT E.CODE-HEAP	.ERROR "Code and Symbols segments overlap"
.ENDC

ALGN4



;	ALGN32		; Align to 32 bytes to simplify GC bit operations
;HEAP:

.IIF NE C$AMAL .INCLUDE	/symdef.mac/

.END	START3
