00010 * The Kernel of BIF: A Dialect of FORTH
00015 * with a Binary Tree Dictionary
00020 * Copyright   1989 by Joel Matthew Rees
00025 *
00030 * BIF is architecturally derived from
00035 * the public domain fig-FORTH model.
00040 * 
00050 *	TITLE BIF kernel 16 Feb 89
00070 	OPT MEX
00080 	INCLUDE BIFU.INC:1
00090 	ORG $1200	DEBIF: $3F00
00100 	INCLUDE BIF.M:1
00110 	INCLUDE BIFDP.ASM:1
00110 	INCLUDE BIFST.ASM:1
00120 	SETDP VDP COLD loads DP
01000 *
01001 	FCC '@' name
01002 	FCB 1 name length, usage (NFA)
01003 	FCB MFORE type/allocation MODES
01004 	FDB WARM-CFAOFF previous link in allocation
01005 	FDB BIF+2 owning vocabulary
01006 	FDB EQ-CFAOFF left link in tree
01007 	FDB AND-CFAOFF right link in tree
01010 FETCH	LDD [,U] from [tos] to stack
01011 	STD ,U
01012 	NEXT
01013 *
01014 	FCC '!'
01015 	FCB 1
01016 	FCB MFORE
01017 	FDB FETCH-CFAOFF
01030 	FDB BIF+2
01040 	FDB NUBLK-CFAOFF
01050 	FDB STOCSP-CFAOFF
01060 STORE	LDD 2,U from stack to [top]
01070 	STD [,U]
01080 	LEAU 4,U
01090 	NEXT
01095 *
01100 	FCC 'LIT'
01110 	FCB MCOMP.OR.3
01120 	FCB MFORE
01130 	FDB STORE-CFAOFF
01140 	FDB BIF+2
01150 	FDB 0 * LIST-CFAOFF
01160 	FDB 0
01170 LIT	LDD ,Y++ push literal from code
01180 	PSHU D
01190 	NEXT
01200 *
01210 	FCC 'DLIT'
01220 	FCB MCOMP.OR.4
01230 	FCB MFORE
01240 	FDB LIT-CFAOFF
01250 	FDB BIF+2
01260 	FDB 0
01270 	FDB 0
01280 * push double literal from code
01290 DLIT	LDD ,Y++
01300 	LDX ,Y++
01310 	PSHU D,X
01320 	NEXT
01330 *
01340 	FCC 'EXECUTE'
01350 	FCB MCOMP.OR.7
01360 	FCB MFORE
01370 	FDB DLIT-CFAOFF
01380 	FDB BIF+2
01390 	FDB 0
01400 	FDB 0
01410 * EXECUTE cfa on stack
01420 EXEC	LDX ,U++
01430 	BEQ *+4
01440 	JMP ,X
01450 	LDD #9
01460 	PSHU D
01462 	JMP ERROR
01464 *
01466 	FCC '1BRANCH'
01468 	FCB MCOMP.OR.7
01470 	FCB MFORE
01472 	FDB EXEC-CFAOFF
01474 	FDB BIF+2
01476 	FDB 0
01478 	FDB 0
01480 TBR	LDD ,U++
01482 	BNE BRANCH
01484 	LEAY 2,Y
01486 	NEXT
01488 *
01490 	FCC 'BRANCH'
01500 	FCB MCOMP.OR.6
01510 	FCB MFORE
01520 	FDB TBR-CFAOFF
01530 	FDB BIF+2
01540 	FDB 0
01550 	FDB 0
01560 BRANCH	LDD ,Y++
01570 	LEAY D,Y
01580 	NEXT
01590 *
01600 	FCC '0BRANCH'
01610 	FCB MCOMP.OR.7
01620 	FCB MFORE
01630 	FDB BRANCH-CFAOFF
01640 	FDB BIF+2
01650 	FDB 0
01660 	FDB 0
01670 ZBR	LDD ,U++
01680 	BEQ BRANCH
01690 	LEAY 2,Y
01700 	NEXT
01710 *
01720 	FCC '(LOOP)'
01730 	FCB MCOMP.OR.6
01740 	FCB MFORE
01750 	FDB ZBR-CFAOFF
01760 	FDB BIF+2
01770 	FDB 0
01780 	FDB 0
01790 XLOOP	LDD #1
01800 	ADDD ,S
01810 	STD ,S
01820 	SUBD 2,S
01830 	BLT BRANCH
01840 XLOOPN	LEAY 2,Y
01850 	LEAS 4,S
01860 	NEXT
01870 *
01880 	FCC '(+LOOP)'
01890 	FCB MCOMP.OR.7
01900 	FCB MFORE
01910 	FDB XLOOP-CFAOFF
01920 	FDB BIF+2
01930 	FDB 0
01940 	FDB 0
01950 XPLOOP	LDD ,U++ inc val
01960 	BPL XLOOP+3
01970 	ADDD ,S
01980 	STD ,S
01990 	SUBD 2,S
02000 	BGT BRANCH
02010 	BRA XLOOPN
02020 *
02030 	FCC '(DO)'
02040 	FCB 4
02050 	FCB MFORE
02060 	FDB XPLOOP-CFAOFF
02070 	FDB BIF+2
02080 	FDB 0
02090 	FDB 0
02100 XDO	PULU D,X
02110 	PSHS D,X
02120 	NEXT
02130 *
02140 	FCC 'I'
02150 	FCB 1
02160 	FCB MFORE
02170 	FDB XDO-CFAOFF
02180 	FDB BIF+2
02190 	FDB HLD-CFAOFF
02200 	FDB IDDOT-CFAOFF
02210 I	LDD ,S
02220 	PSHU D
02222 	NEXT
02224 *
02226 	FCC 'J'
02228 	FCB 1
02230 	FCB MFORE
02232 	FDB I-CFAOFF
02234 	FDB BIF+2
02236 	FDB IPCOM-CFAOFF
02238 	FDB 0
02240 J	LDD 4,S
02242 	PSHU D
02244 	NEXT
02246 *
02250 	FCC 'DIGIT'
02260 	FCB 5
02270 	FCB MFORE
02280 	FDB J-CFAOFF
02290 	FDB BIF+2
02300 	FDB DEC-CFAOFF
02310 	FDB DLITER-CFAOFF
02320 DIGIT	LDB 3,U
02330 	CMPB #'9
02340 	BLS DIGITX+4
02350 	CMPB #'A
02360 	BLO DIGITN
02370 	CMPB #'Z
02380 	BLS DIGITX+2
02390 	CMPB #'a
02400 	BLO DIGITN
02410 	CMPB #'z
02420 	BHI DIGITN
02430 DIGITX	SUBB #'a-'Z-1
02440 	SUBB #'A-'9-1
02450 	SUBB #'0
02460 	CMPB 1,U
02470 	BHS DIGITN
02480 	CLRA
02490 	STD 2,U
02500 	LDD #-1
02510 DIGITL	STD ,U
02520 	NEXT
02530 DIGITN	LEAU 2,U
02540 	LDD #0
02550 	BRA DIGITL
02560 *
02570 	FCC '(FIND)'
02580 	FCB 6
02590 	FCB MFORE
02600 	FDB DIGIT-CFAOFF
02610 	FDB BIF+2
02620 	FDB IABORT-CFAOFF
02630 	FDB XMACH-CFAOFF
02640 * search vocabulary adr2 for (adr1)
02650 PFIND	LDD ,U valid?
02660 	BEQ PFINDX
02670 PFINDL	DOCOL
02680 	FDB PREF
02690 	FDB XMACH
02700 	LEAU 2,U
02710 	LDX [,U] NULL link?
02720 	BEQ PFINDN
02730 	LDB ,X
02740 	ANDB #MHID smudged?
02750 	BEQ PFINDY
02760 	LEAX RTOFF,X deeper
02770 	STX ,U
02780 	BRA PFINDL
02790 PFINDY	LDX #-1
02800 PFINDN	LDD ,U
02810 	STX ,U
02820 PFINDX	STD 2,U
02830 	NEXT
02990 *
03000 	FCC 'ENCLOSE'
03010 	FCB 7
03020 	FCB MFORE
03030 	FDB PFIND-CFAOFF
03040 	FDB BIF+2
03050 	FDB EMTBUF-CFAOFF
03060 	FDB 0
03070 * adr1 c --- adr2 len
03080 ENCLOS	LDX 2,U
03100 ENCLLD	LDB ,X+ delimiter
03110 	BEQ ENCL0
03120 	CMPB 1,U
03130 	BEQ ENCLLD
03133 ENCL0	LEAX -1,X
03140 	STX 2,U
03150 ENCLLW	LDB ,X+ scan word
03160 	BEQ ENCLCA
03170 	CMPB 1,U
03180 	BNE ENCLLW
03190 ENCLCA	TFR X,D length
03195 	SUBD #1
03200 	SUBD 2,U
03220 	STD ,U
03230 	NEXT
03240 *
03250 	FCC 'LITERAL'
03260 	FCB MIMM.OR.7
03270 	FCB MFORE
03280 	FDB ENCLOS-CFAOFF
03290 	FDB BIF+2
03300 	FDB LIT-CFAOFF
03310 	FDB LOAD-CFAOFF
03320 * compile a literal
03330 LITER	BSR LITERS
03340 	LDD #LIT
03350 LITERB	STD ,Y++
03360 	PULU D
03370 	STD ,Y++
03380 	STY UDP,X
03390 	PULS Y
03400 	JMP HERERR
03405 *
03410 LITERS	LDX <UP
03412 	LDB USTATE+1,X
03414 	ANDB #SCOMP
03416 	PULS D no CC
03418 	BNE *+4 compiling?
03420 	NEXT no
03422 	PSHS Y
03424 	LDY UDP,X
03426 	EXG D,PC return
03430 *
03435 	FCC 'DLITERAL'
03440 	FCB MIMM.OR.8
03450 	FCB MFORE
03460 	FDB LITER-CFAOFF
03470 	FDB BIF+2
03480 	FDB DLIT-CFAOFF
03490 	FDB DMINUS-CFAOFF
03500 * compile a 32 bit constant
03510 DLITER	BSR LITERS
03540 	LDD #DLIT
03550 	STD ,Y++
03560 	PULU D
03570 	BRA LITERB
03630 *
08210 	INCLUDE BIFB.ASM:1
08220 	INCLUDE BIF1.ASM:1
08230 	INCLUDE BIF1B.ASM:1
08240 	INCLUDE BIF2.ASM:1
08250 	INCLUDE BIF2B.ASM:1
08260 	INCLUDE BIF3.ASM:1
08270 	INCLUDE BIF3B.ASM:1
08280 	INCLUDE BIF4.ASM:1
08285 	INCLUDE BIF4B.ASM:1
08290 	INCLUDE BIF5.ASM:1
08295 	INCLUDE BIF5B.ASM:1
08300 	INCLUDE BIF6.ASM:1
08310 	INCLUDE BIF6B.ASM:1
08320 	INCLUDE BIF7.ASM:1
08330 	INCLUDE BIF7B.ASM:1
09000 	END