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

;; Subroutines

ASUBR0:

;; (LIST &rest objects) => list
LIST::	MOV	R5, R1		; R5: &REST
RE.LIS:	RETURN

.IIF NE C$RT11, .INCLUDE /calend.mac/


.IF NE C$MVAL

;; (VALUES-LIST list) => element*
VALLS::
	MOV	(R5), R5
;; (VALUES &rest object) => object*
VALUES::
	MOV	R5, MVAL
	MOV	(R5), R1
	RETURN

.ENDC ; C$MVAL

;; (QUIT) => exit into operating system
QUIT::
M.QUIT::
	.EXIT


LOGREC:	COM	R0
LOGRED:	POP	R1
LOGR.0:	.POP5
	BNE	1$
	MOV	R0, R1
	FI16.R
1$:	TO.I16
	JMP	(R4)

;; (LOGAND &rest integers) => result-integer
LOGAND::
	JSR	R4, LOGREC
	COM	R1
	BIC	R1, R0
	BR	LOGR.0

;; (LOGIOR &rest integers) => result-integer
LOGIOR::
	JSR	R4, LOGRED
	BIS	R1, R0
	BR	LOGR.0

;; (LOGXOR &rest integers) => result-integer
LOGXOR::
	JSR	R4, LOGRED
LOGXO1:	XOR	R1, R0
	BR	LOGR.0

;; (LOGEQV &rest integers) => result-integer
LOGEQV::
	JSR	R4, LOGREC
	COM	R0
	BR	LOGXO1

;; (EXTROOM) => free bytes
;; Switches to Extended Memory mode (+12 KB RAM)
;; The operation cannot be reversed
EXTROOM::
.IF NE C$BK10
	MOV	#C.EXTM, R0
	MOVB	R0, $EXTM	; Set ExtMem byte explicitly to non-(0 or 377 value) to prevent switching off
	EMT	16		; Switch on ExtMem mode
	MOV	#HIMEME-HEAP / 32., GCBMSZ
.ENDC	; C$BK10
;	MOV	#HIMEME, EHEAP
;; (ROOM) => free bytes
ROOM::	.GC
ROOM1::	CLR	R1		; R1: free bytes acc
	MOV	#FREEL-2, R2
1$:	ADD	(R2)+, R1
	MOV	(R2), R2
	BNE	1$
	F.U16
	.PRNT           	; R2: 0 here, used as stream
	.P.STR	A.ROOM
RE.ROO:	RETURN

VECTO1:	MOV	R1, R5
;; (VECTOR &rest objects) => vector
VECTOR::
	MOV	R5, R1
	.LENGTH
	.MKAR
	MOV	R1, R2
	INC	R2
	TST	R5
1$:	BEQ	RE.ROO
	MOV	(R5)+, (R2)+	; COPY LIST TO VECTOR
	MOV	(R5), R5
	BR	1$



APPEN1:	TST	R5
	BEQ	1$	; R1: last list
	.SUBR	CPLIST
1$:	.PUSH0
;; (APPEND &rest lists) => result
APPEND::
	.POP5
	BNE	APPEN1
	.NREV0
	MOV	R1, R5
	CLR	R2
NCONC1:	MOV	R2, R0
;; (NCONC &rest lists) => concatenated-list
NCONC::	.POP5
	BEQ	R.0
	.SH210
	BEQ	NCONC1
	.SUBR	LAST1
	MOV	R2, 2(R1)
	BR	NCONC

;; (GET-INTERNAL-REAL-TIME) => internal-time
GETTIM::
.IF NE C$RT11
	.SYS	S$GTIM			; .GTIM	#AREA, #$BUFOUT
	MOV	#$BUFOUT, R3
	CMP	(R3), LSTTIM
	BHI	4$
	BLO	1$
	CMP	2(R3), LSTTIM+2
	BHIS	4$

;; roll over 24h
1$:	MOV	#60., R2		; R2: 60 hZ
	MOV     $SYPTR, R1
	BIT 	#^B100000, 300(R1)
	BEQ	5$
	MOV	#50., R2		; R2: 50 hZ
5$:	MOV	#24., R5
2$:	MOV	#60. *60., R4
3$:	ADD	R2, TIMADD+2
	ADC	TIMADD
	SOB	R4, 3$
	SOB	R5, 2$

4$:	MOV	(R3)+, LSTTIM
	MOV	(R3), LSTTIM+2		; R3: $BUFOUT+2

	ADD	TIMADD+2, (R3)
	ADC	-(R3)
	ADD	TIMADD, (R3)

	CLR	R0
	MOV	#F65536+2, R1
	.PUSH0
	MOV	(R3)+, R1		; $BUFOUT
	F.U16
	.PUSH0
	MOV	R0, R5
	.SUBR	S.MUL
	CLR	R0
	.PUSH0
	MOV	(R3), R1		; $BUFOUT+2
	F.U16
	.PUSH0
.IFF
	MOV	#$TMCNT, R2
	MOV	(R2)+, R1		; Read CNT
	TSTB	(R2)			; R2: $TMCSR, test CSR.FL bit (overflow)
	BPL	1$			; No overflow, R1 contains count
	MOV	#F32768 + 2, R1		; Add duration of one timer cycle 65536==2*32768
	.PUSH0
	.PUSH0
	MOV	@#$TMCNT, R1		; Re-read CNT because of Race cond. with two volatile vars: FL and CNT, recheck
1$:	MOV	#$TMFMN, (R2)		; Reset Timer, R2: $TMCSR
	NEG	R1
	F.U16
	.PUSH0
	MOV	PRVTIM, R1
	.PUSH0
.ENDC	; C$RT11
	MOV	R0, R5
	.SUBR	S.ADD
	MOV	R1, PRVTIM
	RETURN

;; Multiply list in R1
S.MUL1:	MOV	R1, R5
;; (* &rest numbers) => product
S.MUL::	MOV	#$DMUL, R4
	INC	R0
	BR	ADDMUL

;; (+ &rest numbers) => sum
S.ADD::	MOV	#$DADD, R4
ADDMUL:	ADD	#V.0, R0
	MOV	R5, R2
	BEQ	R.0
	JMP	REDUC2

;; (INKEY) => char-p
INKEY::
.IF NE C$BK10
	TSTB	$TSTKEY
	BEQ	R.0		; no pressed key
	.TTYIN	R1
.IFF
	.IF NE C$BK11
		.BINKEY
		BCS	R.0	; no pressed key
		MOV	R0, R1
	.IFF
		.TTINR
		BCS	R.0	; no pressed key
	.ENDC ; C$BK11
.ENDC ; C$BK10
	BR	CODEC3		; (CODE-CHAR R1)

;; (Y-OR-N-P &optional control &rest arguments) => generalized-boolean
YORNP::	TST	R5
	BEQ	2$
	CLR	R1		; R1: NIL (terminal stream)
	.FRESHL			; (FRESH-LINE NIL)
	MOV	#V.T, R1
	.FORMAT			; (APPLY 'FORMAT T control arguments)
1$:     CLR	R2		; R3: terminal stream
	.P.CHR	C.SP, 'Y	; " Y/N" prompt
	.P.CHR	'/, 'N
2$:	.SUBR	INKEY		; (INKEY)
	BEQ	2$		; wait for input
	.CHRUP			; (CHAR-UPCASE char)
	CMP	R1, #V.C.Y
	BEQ.T
	CMP	R1, #V.C.N
	BEQ.F
	BR	1$

.IF NE C$RT11
;; (SOFTWARE-VERSION) => description
SVER::	ADD	#V.SVER - V.STYP, R0
;; (SOFTWARE-TYPE) => description
STYP::	ADD	#V.STYP - V.MTYP, R0
.ENDC	; C$RT11

;; (MACHINE-TYPE) => description
MTYP::	ADD	#V.MTYP - V.MVER, R0
;; (MACHINE-VERSION) => description
MVER::	ADD	#V.MVER - V.LTYP, R0
;; (LISP-IMPLEMENTATION-TYPE) => description
LTYP::	ADD	#V.LTYP - V.LVER, R0
;; (LISP-IMPLEMENTATION-VERSION) => description
LVER::	ADD	#V.LVER, R0
R.0:	MOV	R0, R1
	RETURN




.INCLUDE /subr1.mac/
.INCLUDE /subr2.mac/
.INCLUDE /subr3.mac/


;;;---------------------------------------------------------------------------------
ASUBR4:
