Hyperlinked SOL-86 Kernel
\ SOL Kernel for the 8086, Version 0.7.2
\ Copyright (C) 2001,2004 Nils M Holm.
\ hex 0000 const r0
\ hex fe00 const s0
\ hex f800 const dtb
\ hex f400 const fbl
\ hex f3b0 const tib
\ ----- initialization -----
\
235 c, 4 c, \ jmp +6
0 , \ 'sol (backpatched)
0 , \ bdev
0 , \ xseg
137 c, 22 c, 1284 , \ mov [0504],dx \ bdev
140 c, 200 c, \ mov ax,cs
142 c, 216 c, \ mov ds,ax
142 c, 192 c, \ mov es,ax
142 c, 208 c, \ mov ss,ax
188 c, 0 , \ mov sp,0 \ r0
189 c, 65024 , \ mov bp,fe00 \ s0
252 c, \ cld
161 c, 1282 , \ mov ax,[0502] \ 'sol
255 c, 224 c, \ jmp ax
\ ----- primitives -----
\
\d halt ( -- ) m-- | halt the machine
:h halt
ff ff \ illegal instruction, stops emulator
eb fe \ jmp -2
next;
\d nointr ( -- ) m-- | disable interrupts
:h nointr
fa \ cli
next;
\d intr ( -- ) m-- | enable interrupts
:h intr
fb \ sti
next;
\d p@ ( p -- n ) m-- | read 16-bit i/o port
:h p@
89 da \ mov dx,bx
ed \ in ax,dx
89 c3 \ mov bx,ax
next;
\d p! ( n p -- ) m-- | write 16-bit i/o port
:h p!
8b 46 00 \ mov ax,[bp+00]
89 da \ mov dx,bx
ef \ out dx,ax
8b 5e 02 \ mov bx,[bp+02]
83 c5 04 \ add bp,04
next;
\d cp@ ( p -- c ) m-- | read 8-bit i/o port
:h cp@
89 da \ mov dx,bx
ec \ in al,dx
30 e4 \ xor ah,ah
89 c3 \ mov bx,ax
next;
\d cp! ( c p -- ) m-- | write 8-bit i/o port
:h cp!
8b 46 00 \ mov ax,[bp+00]
89 da \ mov dx,bx
ee \ out dx,al
8b 5e 02 \ mov bx,[bp+02]
83 c5 04 \ add bp,04
next;
\d (:) ( ; a -- a' ) m-- | address list interpreter
:h (:)
58 \ pop ax
56 \ push si
89 c6 \ mov si,ax
next;
\d (lit) ( -- n ) m-- | push inline literal number
:h (lit)
83 ed 02 \ sub bp,02
89 5e 00 \ mov [bp+00],bx
ad \ lodsw
89 c3 \ mov bx,ax
next;
\d (var) ( -- a ) m-- | run time for variables
:h (var)
83 ed 02 \ sub bp,02
89 5e 00 \ mov [bp+00],bx
5b \ pop bx
next;
\d (const) ( -- n ) m-- | run time for constants
:h (const)
83 ed 02 \ sub bp,02
89 5e 00 \ mov [bp+00],bx
5b \ pop bx
8b 1f \ mov bx,[bx]
next;
\d exit ( ; a -- ) m-- | return from thread
:h exit
5e \ pop si
next;
\d exec ( a -- ) m-- | execute word
:h exec
89 d8 \ mov ax,bx
8b 5e 00 \ mov bx,[bp+00]
83 c5 02 \ add bp,02
ff e0 \ jmp ax
next;
\d dup ( n -- n n ) m-- | duplicate tos
:h dup
83 ed 02 \ sub bp,02
89 5e 00 \ mov [bp+00],bx
next;
\d drop ( n -- ) m-- | discard tos
:h drop
8b 5e 00 \ mov bx,[bp+00]
83 c5 02 \ add bp,02
next;
\d swap ( n m -- m n ) m-- | swap tos and tos-1
:h swap
87 5e 00 \ xchg bx,[bp+00]
next;
\d over ( n m -- n m n ) m-- | duplicate tos-1
:h over
83 ed 02 \ sub bp,02
89 5e 00 \ mov [bp+00],bx
8b 5e 02 \ mov bx,[bp+02]
next;
\d rot ( n m k -- m k n ) m-- | rotate stack up
:h rot
8b 46 02 \ mov ax,[bp+02]
8b 56 00 \ mov dx,[bp+00]
89 56 02 \ mov [bp+02],dx
89 5e 00 \ mov [bp+00],bx
89 c3 \ mov bx,ax
next;
\d @ ( a -- n ) m-- | indirection
:h @
8b 1f \ mov bx,[bx]
next;
\d c@ ( a -- c ) m-- | byte indirection
:h c@
8a 1f \ mov bl,[bx]
30 ff \ xor bh,bh
next;
\d ! ( n a -- ) m-- | store machine word
:h !
8b 46 00 \ mov ax,[bp+00]
89 07 \ mov [bx],ax
8b 5e 02 \ mov bx,[bp+02]
83 c5 04 \ add bp,04
next;
\d c! ( c a -- ) m-- | store byte
:h c!
8b 46 00 \ mov ax,[bp+00]
88 07 \ mov [bx],al
8b 5e 02 \ mov bx,[bp+02]
83 c5 04 \ add bp,04
next;
\d sp@ ( -- a ) m-- | push stack pointer
:h sp@
83 ed 02 \ sub bp,02
89 5e 00 \ mov [bp+00],bx
89 eb \ mov bx,bp
next;
\d sp! ( a -- ? ) m-- | pop stack pointer
:h sp!
89 dd \ mov bp,bx
next;
\d rp@ ( -- a ) m-- | push return stack pointer
:h rp@
83 ed 02 \ sub bp,02
89 5e 00 \ mov [bp+00],bx
89 e3 \ mov bx,sp
next;
\d rp! ( a -- ; -- ? ) m-- | pop return stack pointer
:h rp!
89 dc \ mov sp,bx
8b 5e 00 \ mov bx,[bp+00]
83 c5 02 \ add bp,02
next;
\d >r ( n -- ; -- n ) m-- | transfer value to rstack
:h >r
53 \ push bx
8b 5e 00 \ mov bx,[bp+00]
83 c5 02 \ add bp,02
next;
\d r> ( -- n ; n -- ) m-- | transfer value from rstack
:h r>
83 ed 02 \ sub bp,02
89 5e 00 \ mov [bp+00],bx
5b \ pop bx
next;
\d r@ ( -- n ) m-- | copy value from rstack
:h r@
83 ed 02 \ sub bp,02
89 5e 00 \ mov [bp+00],bx
89 e7 \ mov di,sp
8b 1d \ mov bx,[di]
next;
\d rdrop ( -- ; n -- ) m-- | drop top of rstack
:h rdrop
58 \ pop ax
next;
\d x@ ( a -- n ) m-- | external segment access
:h x@
06 \ push es
8e 06 06 05 \ mov es,[0506] \ xseg
26 \ es:
8b 1f \ mov bx,[bx]
07 \ pop es
next;
\d x! ( n a -- ) m-- | store machine word in xseg
:h x!
8b 46 00 \ mov ax,[bp+00]
06 \ push es
8e 06 06 05 \ mov es,[0506] \ xseg
26 \ es:
89 07 \ mov [bx],ax
07 \ pop es
8b 5e 02 \ mov bx,[bp+02]
83 c5 04 \ add bp,04
next;
\d + ( n m -- n+m ) m-- | sum
:h +
03 5e 00 \ add bx,[bp+00]
83 c5 02 \ add bp,02
next;
\d - ( n m -- n-m ) m-- | difference
:h -
87 5e 00 \ xchg bx,[bp+00]
2b 5e 00 \ sub bx,[bp+00]
83 c5 02 \ add bp,02
next;
\d * ( n m -- n*m ) m-- | product
:h *
8b 46 00 \ mov ax,[bp+00]
83 c5 02 \ add bp,02
f7 eb \ imul bx
89 c3 \ mov bx,ax
next;
\d /mod ( n m -- n/m n mod m ) m-- | quotient+modulus
:h /mod
8b 46 00 \ mov ax,[bp+00]
99 \ cwd
f7 fb \ idiv bx
89 46 00 \ mov [bp+00],ax
89 d3 \ mov bx,dx
next;
\d u/mod ( u v -- u/v u mod v ) m-- | unsigned quot+mod
:h u/mod
8b 46 00 \ mov ax,[bp+00]
31 d2 \ xor dx,dx
f7 f3 \ div bx
89 46 00 \ mov [bp+00],ax
89 d3 \ mov bx,dx
next;
\d and ( u v -- u/\v ) m-- | bitwise logical product
:h and
23 5e 00 \ and bx,[bp+00]
83 c5 02 \ add bp,02
next;
\d or ( u v -- u\/v ) m-- | bitwise logical sum
:h or
0b 5e 00 \ or bx,[bp+00]
83 c5 02 \ add bp,02
next;
\d xor ( u v -- u xor v ) m-- | bitwise logical exclusive or
:h xor
33 5e 00 \ xor bx,[bp+00]
83 c5 02 \ add bp,02
next;
\d shl ( u v -- u shl v ) m-- | bitwise left shift
:h shl
8b 4e 00 \ mov cx,[bp+00]
87 cb \ xchg cx,bx
d3 e3 \ shl bx,cl
83 c5 02 \ add bp,02
next;
\d shr ( u v -- u shr v ) m-- | bitwise right shift
:h shr
8b 4e 00 \ mov cx,[bp+00]
87 cb \ xchg cx,bx
d3 eb \ shr bx,cl
83 c5 02 \ add bp,02
next;
\d neg ( n -- -n ) m-- | negation
:h neg
f7 db \ neg bx
next;
\d inv ( u -- inv u ) m-- | bitwise complement
:h inv
f7 d3 \ not bx
next;
\d 1+ ( n -- n+1 ) m-- | increment
:h 1+
ff c3 \ inc bx
next;
\d 1- ( n -- n-1 ) m-- | decrement
:h 1-
ff cb \ dec bx
next;
\d +! ( n a -- ) m-- | increment address by value
:h +!
8b 46 00 \ mov ax,[bp+00]
01 07 \ add [bx],ax
8b 5e 02 \ mov bx,[bp+02]
83 c5 04 \ add bp,04
next;
\d bsz ( u -- v ) m-- | bitwise scan for zero
:h bsz
31 c0 \ xor ax,ax
f7 c3 01 00 \ test bx,0001
74 05 \ jz +5
d1 eb \ shr bx,1
40 \ inc ax
eb f5 \ jmp -b
89 c3 \ mov bx,ax
next;
\d < ( n m -- n<m ) m-- | 'less than' predicate
:h <
8b 46 00 \ mov ax,[bp+00]
83 c5 02 \ add bp,02
39 d8 \ cmp ax,bx
7c 05 \ jl +5
31 db \ xor bx,bx
next,
bb ff ff \ mov bx,ffff
next;
\d > ( n m -- n>m ) m-- | 'greater than' predicate
:h >
8b 46 00 \ mov ax,[bp+00]
83 c5 02 \ add bp,02
39 d8 \ cmp ax,bx
7f 05 \ jg +5
31 db \ xor bx,bx
next,
bb ff ff \ mov bx,ffff
next;
\d u< ( u v -- u<v ) m-- | 'unsigned less' predicate
:h u<
8b 46 00 \ mov ax,[bp+00]
83 c5 02 \ add bp,02
39 d8 \ cmp ax,bx
72 05 \ jb +5
31 db \ xor bx,bx
next,
bb ff ff \ mov bx,ffff
next;
\d u> ( u v -- u>v ) m-- | 'unsigned greater' predicate
:h u>
8b 46 00 \ mov ax,[bp+00]
83 c5 02 \ add bp,02
39 d8 \ cmp ax,bx
77 05 \ ja +5
31 db \ xor bx,bx
next,
bb ff ff \ mov bx,ffff
next;
\d = ( n m -- n=m ) m-- | 'equal to' predicate
:h =
8b 46 00 \ mov ax,[bp+00]
83 c5 02 \ add bp,02
39 d8 \ cmp ax,bx
74 05 \ jz +5
31 db \ xor bx,bx
next,
bb ff ff \ mov bx,ffff
next;
\d not ( f -- not f ) m-- | logical complement
:h not
09 db \ or bx,bx
74 05 \ jz 02ec
31 db \ xor bx,bx
next,
bb ff ff \ mov bx,ffff
next;
\d cmove> ( src dst n -- ) m-- | move memory region up
:h cmove>
56 \ push si
89 d9 \ mov cx,bx \ length
8b 7e 00 \ mov di,[bp+00] \ source
8b 76 02 \ mov si,[bp+02] \ destination
01 ce \ add si,cx \ start at last byte
ff ce \ dec si
01 cf \ add di,cx
ff cf \ dec di
fd \ std \ doit
f3 \ repz
a4 \ movsb
fc \ cld
83 c5 06 \ add bp,06
8b 5e fe \ mov bx,[bp-02]
5e \ pop si
next;
\d <cmove ( src dst n -- ) m-- | move memory region down
:h <cmove
56 \ push si
89 d9 \ mov cx,bx
8b 7e 00 \ mov di,[bp+00] \ source
8b 76 02 \ mov si,[bp+02] \ destination
f3 \ repz
a4 \ movsb
5e \ pop si
83 c5 06 \ add bp,06
8b 5e fe \ mov bx,[bp-02]
next;
\d cscan ( a n c -- a|0 ) m-- | search byte in memory
:h cscan
89 d8 \ mov ax,bx
8b 4e 00 \ mov cx,[bp+00]
8b 7e 02 \ mov di,[bp+02]
31 db \ xor bx,bx
f2 \ repnz
ae \ scasb
75 04 \ jnz +4
89 fb \ mov bx,di
ff cb \ dec bx
83 c5 04 \ add bp,04
next;
\d -text ( a1 a2 n -- n ) m-- | compare strings
:h -text
56 \ push si
89 d9 \ mov cx,bx \ load regs
8b 7e 00 \ mov di,[bp+00]
8b 76 02 \ mov si,[bp+02]
31 db \ xor bx,bx \ assume equal
f3 \ repz
a6 \ cmpsb
74 0b \ jz +b \ equal => .end
ff ce \ dec si \ compute delta
ff cf \ dec di
8a 04 \ mov al,[si]
2a 05 \ sub al,[di]
98 \ cbw
89 c3 \ mov bx,ax
83 c5 04 \ add bp,04 \ .end
5e \ pop si
next;
\d fill ( a n c -- ) m-- | fill memory region
:h fill
89 d8 \ mov ax,bx
8b 4e 00 \ mov cx,[bp+00]
8b 7e 02 \ mov di,[bp+02]
f3 \ repz
aa \ stosb
83 c5 06 \ add bp,06
8b 5e fe \ mov bx,[bp-02]
next;
\d (br) ( -- ) m-- | branch to inline address
:h (br)
8b 34 \ mov si,[si]
next;
\d (bf) ( f -- ) m-- | branch on false to inline address
:h (bf)
89 d8 \ mov ax,bx
8b 5e 00 \ mov bx,[bp+00]
83 c5 02 \ add bp,02
09 c0 \ or ax,ax
75 05 \ jnz +5
8b 34 \ mov si,[si]
next,
83 c6 02 \ add si,02
next;
\d lookup ( a x -- 0|a -1 ) m-- | find lfa of lexicon entry
:h lookup
56 \ push si
89 de \ mov si,bx \ .find; si = lex ptr
83 c6 02 \ add si,02 \ >name
ac \ lodsb
80 e0 7f \ and al,7f \ mask syntax flag
8b 7e 00 \ mov di,[bp+00] \ name to find
8a 25 \ mov ah,[di]
ff c7 \ inc di
38 e0 \ cmp al,ah \ compare lengths
75 12 \ jnz +12 \ unequal => .next
30 e4 \ xor ah,ah \ compare names
89 c1 \ mov cx,ax
f3 \ repz
a6 \ cmpsb
75 0a \ jnz +a \ unequal => .next
89 5e 00 \ mov [bp+00],bx \ found, push entry
bb ff ff \ mov bx,ffff \ and success flag
5e \ pop si
next, \ .next
8b 1f \ mov bx,[bx] \ go to next entry
09 db \ or bx,bx \ end of lexicon?
75 d4 \ jnz -2c \ no => .find
83 c5 02 \ add bp,02 \ remove lex ptr
31 db \ xor bx,bx \ push failure flag
5e \ pop si
next;
\ ----- BIOS interface -----
\ Warning: self-modifying code ahead
\
\d bios ( regs int -- regs flags ) m-- | bios interrupt
:h bios
56 \ push si
e8 00 00 \ call +0
5e \ pop si
88 5c 17 \ mov [si+17],bl
8b 7e 00 \ mov di,[bp+00]
8b 76 02 \ mov si,[bp+02]
8b 56 04 \ mov dx,[bp+04]
8b 4e 06 \ mov cx,[bp+06]
8b 5e 08 \ mov bx,[bp+08]
8b 46 0a \ mov ax,[bp+0a]
cd 00 \ int (patched)
9c \ pushf
89 46 0a \ mov [bp+0a],ax
89 5e 08 \ mov [bp+08],bx
89 4e 06 \ mov [bp+06],cx
89 56 04 \ mov [bp+04],dx
89 76 02 \ mov [bp+02],si
89 7e 00 \ mov [bp+00],di
5b \ pop bx
5e \ pop si
next;
\ ----- keyboard and video routines -----
\ Could be done using BIOS, kept in machine code for speed.
\
\d (?kbrdy) ( -- f ) m-- | internal keyboard ready?
:h (?kbrdy)
83 ed 02 \ sub bp,02
89 5e 00 \ mov [bp+00],bx
b8 00 01 \ mov ax,0100 \ service 01
cd 16 \ int 16 \ bios int 16
74 06 \ jz +6
bb ff ff \ mov bx,ffff
next,
31 db \ xor bx,bx
next;
\d (key) ( -- c ) m-- | read internal keyboard
:h (key)
83 ed 02 \ sub bp,02
89 5e 00 \ mov [bp+00],bx
31 c0 \ xor ax,ax \ service 0
cd 16 \ int 16 \ bios int 16
08 c0 \ or al,al \ extended code?
74 07 \ jz +7 \ yes => .ext
30 e4 \ xor ah,ah
89 c3 \ mov bx,ax
next,
86 e0 \ xchg ah,al \ .ext
81 c0 00 01 \ add ax,0100
89 c3 \ mov bx,ax
next;
\d emitc ( c n -- ) m-- | write to internal screen w/ color
:h emitc
8b 46 00 \ mov ax,[bp+00] \ char
30 ff \ xor bh,bh \ attributes
80 f8 20 \ cmp al,20 \ control char?
7c 07 \ jl +7 \ yes: .type
b9 01 00 \ mov cx,0001 \ single char
b4 09 \ mov ah,09 \ service 9
cd 10 \ int 10 \ bios int 10
3c 08 \ cmp al,08 \ .type
74 0f \ jz +0f \ .braindead
b4 0e \ mov ah,0e \ bios serv e
31 db \ xor bx,bx \ page 0
cd 10 \ int 10 \ bios int 10
8b 5e 02 \ mov bx,[bp+02] \ remove args
83 c5 04 \ add bp,04
next,
\ .braindead: work around destructive backspace
b8 00 03 \ mov ax,0300 \ serv 3 (get csr)
31 db \ xor bx,bx \ page 0
cd 10 \ int 10 \ bios int 10
b8 00 02 \ mov ax,0200 \ serv 2 (set csr)
fe ca \ dec dl \ column
cd 10 \ int 10 \ bios int 10
8b 5e 02 \ mov bx,[bp+02] \ remove args
83 c5 04 \ add bp,04
next;
\d cursor ( x y -- ) m-- | move internal cursor
:h cursor
88 de \ mov dh,bl \ row
8b 46 00 \ mov ax,[bp+00] \ column
88 c2 \ mov dl,al
81 ea 01 01 \ sub dx,0101 \ corner = (0,0)
b8 00 02 \ mov ax,0200 \ service 2
31 db \ xor bx,bx \ page 0
cd 10 \ int 10 \ bios int 10
8b 5e 02 \ mov bx,[bp+02]
83 c5 04 \ add bp,04
next;
\ ----- constants -----
\
\d 0 ( -- 0 ) c-- | constant 0
0 const 0
\d 1 ( -- 1 ) c-- | constant 1
1 const 1
\d 2 ( -- 2 ) c-- | constant 2
2 const 2
\d -1 ( -- -1 ) c-- | constant -1
hex ffff const -1
\d true ( -- -1 ) c-- | logical truth
-1 const true
\d false ( -- 0 ) c-- | logical falsity
0 const false
\d bl ( -- c ) c-- | constant blank
32 const bl
\d bpc ( -- n ) c-- | constant bytes per cell
2 const bpc
\d b/blk ( -- 1024 ) c-- | bytes per block
1024 const b/blk
\d b/r ( -- 64 ) c-- | bytes per record
64 const b/r
\d r/blk ( -- 16 ) c-- | records per block
16 const r/blk
\d s0 ( -- a ) a-- | bottom of data stack
hex fe00 const s0
\d r0 ( -- a ) c-- | bottom of return stack (hex 10000 mod)
hex 0000 const r0
\d dtb ( -- a ) c-- | disk transfer buffer address
hex f800 const dtb
\d fbl ( -- a ) c-- | free block list address
hex f400 const fbl
\d tib ( -- a ) c-- | terminal input buffer address
hex f3b0 const tib
\d top ( -- a ) c-- | top of lexicon space
hex f3b0 const top
\d b.init ( -- n ) c-- | initialization block
17 const b.init
\d b.fbl ( -- n ) c-- | free list block
19 const b.fbl
\d 'sol ( -- a ) v-- | kernel boot address (var ptr!)
hex 0502 const 'sol
\d bdev ( -- a ) v-- | boot device id (var ptr!)
hex 0504 const bdev
\d xseg ( -- a ) v-- | external segment (var ptr!)
hex 0506 const xseg
\d f.c ( -- n ) c-- | 8086 carry flag
hex 0001 const f.c
\d f.z ( -- n ) c-- | 8086 zero flag
hex 0040 const f.z
\d k.up ( -- n ) c-- | key code: up arrow
256 const k.up
\d k.down ( -- n ) c-- | key code: down arrow
257 const k.down
\d k.right ( -- n ) c-- | key code: right arrow
258 const k.right
\d k.left ( -- n ) c-- | key code: left arrow
259 const k.left
\ ----- core words -----
\
\d h ( -- a ) v-- | beginning of heap
0 var h
\d here ( -- a ) t-- | beginning of heap
: here ( -- a ) h @ ;
\d allot ( n -- ) t-- | allocate bytes
: allot ( n -- ) here + h ! ;
\d , ( n -- ) t-- | compile cell
: , ( n -- ) here ! bpc allot ;
\d c, ( c -- ) t-- | compile byte
: c, ( c -- ) here c! 1 allot ;
\d nip ( n m -- m ) t-- | drop tos-1
: nip ( n m -- m ) swap drop ;
\d -rot ( n m k -- k n m ) t-- | rotate stack down
: -rot ( n m k -- k n m ) rot rot ;
\d 0= ( n -- f ) t-- | test for zero
' not alias 0= ( n -- f )
\d 0< ( n -- f ) t-- | test for less than zero
: 0< ( n m -- n<m ) 0 < ;
\d 0> ( n -- f ) t-- | test for greater than zero
: 0> ( n m -- n>m ) 0 > ;
\d 2dup ( n m -- n m n m ) t-- | duplicate tos and tos-1
: 2dup ( n m -- n m n m ) over over ;
\d 2drop ( n m -- ) t-- | drop tos and tos-1
: 2drop ( n m -- ) drop drop ;
\d d= ( n m k l -- n=k/\m=l ) t-- | compare two pairs
: d= ( n m k l -- n=k/\m=l ) rot = -rot = and ;
\d cell+ ( n -- n+bpc ) t-- | advance to next cell
: cell+ ( n -- n+bpc ) bpc + ;
\d cell- ( n -- n-bpc ) t-- | go back one cell
: cell- ( n -- n-bpc ) bpc - ;
\d cells ( u -- v ) t-- | convert bytes to cells
: cells ( u -- v ) 1+ 1 shr ( u bpc 1- + bpc / ) ;
\d depth ( -- n ) t-- | push depth of stack
: depth ( -- n ) s0 cell- cell- sp@ - cells ;
\d <= ( n m -- n<=m ) t-- | 'less than/equal to' predicate
: <= ( n m -- n<=m ) > not ;
\d >= ( n m -- n>=m ) t-- | 'greater than/equal to' predicate
: >= ( n m -- n>=m ) < not ;
\d u<= ( u v -- u<=v ) t-- | 'unsigned less/equal' predicate
: u<= ( u v -- u<=v ) u> not ;
\d u>= ( u v -- u>=v ) t-- | 'unsigned greater/equal' pred.
: u>= ( u v -- u>=v ) u< not ;
\d <> ( n m -- n<>m ) t-- | 'not equal to' predicate
: <> ( u v -- u>=v ) = not ;
\d within ( n l h -- f ) t-- | range check: l <= n <= h
: within ( n l h -- f ) rot dup rot <= -rot <= and ;
\d count ( a -- a n ) t-- | extract length of string
: count ( a -- a n ) dup 1+ swap c@ ;
\d s+ ( a n -- a+1 n-1 ) t-- | move to next char of string
: s+ ( a n -- a+1 n-1 ) 1- swap 1+ swap ;
\d 2+ ( n -- n+2 ) t-- | increment by 2
: 2+ ( n -- n+2 ) 1+ 1+ ;
\d 2- ( n -- n-2 ) t-- | decrement by 2
: 2- ( n -- n-2 ) 1- 1- ;
\d / ( n m -- n/m ) t-- | signed quotient
: / ( n m -- n/m ) /mod drop ;
\d mod ( n m -- n mod m ) t-- | modulus
: mod ( n m -- n mod m ) /mod nip ;
\d u/ ( u -- u/v ) t-- | unsigned quotient
: u/ ( u v -- u/v ) u/mod drop ;
\d umod ( u v -- u mod v ) t-- | unsigned modulus
: umod ( u v -- u mod v ) u/mod nip ;
\d abs ( n -- |n| ) t-- | absolute value
: abs ( n -- |n| ) dup 0< if neg then ;
\d min ( n m -- n|m ) t-- | minimum
: min ( n m -- n|m ) 2dup < if drop else nip then ;
\d max ( n m -- n|m ) t-- | maximum
: max ( n m -- n|m ) 2dup < if nip else drop then ;
\ ----- lexicon functions -----
\
\d lexicon ( -- a ) v-- | pointer to lexicon
0 var lexicon
\d last ( -- a ) v-- | ptr to last created word
0 var last
\d fence ( -- a ) v-- | top of protected area
0 var fence
\d >dict ( -- a ) v-- | beginning of dictionary
0 var >dict
\d l>code ( a -- a ) t-- | move from link to code field
: l>code ( a -- a ) cell+ dup c@ 127 and + cell+ ;
\d p>code ( a -- a ) t-- | move from parameter to code field
: p>code ( a -- a ) 1- cell- ;
\d >name ( a -- a ) t-- | move from code to name field
: >name ( a -- a ) 1- dup c@ - 1- ;
\d >link ( a -- a ) t-- | move from code to link field
: >link ( a -- a ) >name cell- ;
\d >pfa ( a -- a ) t-- | move from code to parameter field
: >pfa ( a -- a ) 1+ cell+ ;
\ ----- compilation -----
\
\d lit ( n -- ) t-- | compile literal
: lit ( n -- ) (lit) (lit) , , ;
\d syntax ( -- ) t-- | make last word syntax word
: syntax ( -- ) last @ l>code >name dup c@ 128 or swap c! ;
defer '
\d escape ( -- ) tsi | compile syntax word
: escape ( -- ) ' , ; syntax
\d ['] ( -- a ) tsi | compile code address of word
: ['] ( -- a ) ' lit ; syntax
\d compile ( -- ) tsi | compile code to compile word
: compile ( -- ) escape ['] ['] , , ; syntax
\ ----- flow control -----
\
\d recurse ( -- ) ts- | call current definition
: recurse ( -- ) last @ l>code , ; syntax
\d mark ( -- a ) t-- | generate mark for backpatching
: mark ( -- a ) here 0 , ;
\d resolve ( a -- ) t-- | backpatch marked address
: resolve ( a -- ) here swap ! ;
\d if ( f -- ) ts- | introduce if-else-then
: if ( f -- ) compile (bf) mark ; syntax
\d else ( -- ) ts- | else part of if-else-then
: else ( -- ) compile (br) mark swap resolve ; syntax
\d then ( -- ) ts- | delimit if-else-then
: then ( -- ) resolve ; syntax
\d begin ( -- ) ts- | introduce loop
: begin ( -- ) here ; syntax
\d while ( f -- ) ts- | condition of begin-while-repeat
: while ( f -- ) escape if ; syntax
\d repeat ( -- ) ts- | delimit begin-while-repeat
: repeat ( -- ) compile (br) swap , resolve ; syntax
\d again ( -- ) ts- | delimit begin-again
: again ( -- ) compile (br) , ; syntax
\d until ( f -- ) ts- | delimit begin-until
: until ( f -- ) compile (bf) , ; syntax
\d for ( n -- ) ts- | introduce for-next
: for ( n -- ) compile >r here ; syntax
\d (next) ( -- f ; n -- [n] ) t-- | runtime of next
: (next) ( -- f ; n -- [n] ) r> r> 1- dup if
>r false else drop true then swap >r ;
\d next ( -- ) ts- | delimit for-next
: next ( -- ) compile (next) compile (bf) , ; syntax
\d (do) ( i' i -- ; -- i' i ) t-- | runtime of do
: (do) ( i' i -- ; -- i' i ) swap r> -rot >r >r >r ;
\d do ( i' i -- ) ts- | introduce do-loop
: do ( i' i -- ) compile (do) here ; syntax
\d (loop) ( -- f ; i' i -- [i' i] ) t-- | runtime of loop
: (loop) ( -- f ; i' i -- [i' i] ) r> r> 1+ r> 2dup u> if
2drop true else >r >r false then swap >r ;
\d loop ( -- ) ts- | delimit do-loop
: loop ( -- ) compile (loop) compile (bf) , ; syntax
\d i ( -- i ) t-- | for-next/do-loop index
: i ( -- i ) r> r@ swap >r ;
\d i' ( -- i' ) t-- | do-loop limit
: i' ( -- i' ) r> r> r@ -rot >r >r ;
\d break ( ; n -- 1 ) t-- | leave for-next
: break ( ; n -- 1 ) r> rdrop 1 >r >r ;
\d leave ( ; i' i -- i' i' ) t-- | leave do-loop
: leave ( -- i' i -- i' i' ) r> r> r> nip dup >r >r >r ;
\d unfor ( ; i -- ) t-- | remove for-next parameter
' rdrop alias unfor ( ; i -- )
\d unloop ( ; i' i -- ) t-- | remove do-loop parameters
: unloop ( -- ) r> rdrop rdrop >r ;
\d case ( -- ) ts- | introduce case
: case ( -- ) 0 ; syntax
\d => ( f -- ) ts- | introduce case of case
: => ( f -- ) escape if ; syntax
\d ;; ( -- ) ts- | delimit case of case
: ;; ( -- ) escape else ; syntax
\d else> ( -- ) ts- | introduce default of case
: else> ( -- ) ; syntax
\d end ( -- ) ts- | delimit case
: end ( -- ) begin dup while
resolve repeat drop ; syntax
\d ?dup ( n -- n [n] ) t-- | dup if tos not zero
: ?dup ( -- ) dup if dup then ;
\d ?if ( f -- f| ) ts- | short form of ?dup if
: ?if ( f -- f| ) compile ?dup escape if ; syntax
\d ?while ( f -- f| ) ts- | short form of ?dup while
: ?while ( f -- f| ) compile ?dup escape while ; syntax
\d ?break ( f -- ) t-- | break if tos true
: ?break ( f -- ) if r> break >r then ;
\d ?leave ( f -- ) t-- | leave if tos true
: ?leave ( f -- ) if r> leave >r then ;
\d ?exit ( f -- ) t-- | exit if tos true
: ?exit ( f -- ) if rdrop then ;
\ ----- bios interface helpers -----
\
\d zeroes ( n -- 0^n ) t-- | push some zeroes
: zeroes ( n -- 0^n ) for 0 next ;
\d ndrop ( x^n -- ) t-- | drop n cells
: ndrop ( x^n -- ) for drop next ;
\ ----- console i/o -----
\
\d color ( -- a ) v-- | internal video attribute
hex 07 var color
\d cpos ( -- x y ) t-- | get cursor position
: cpos ( -- x y ) [hex] 0300 5 zeroes [hex] 10 bios
3 ndrop >r 3 ndrop r> dup 255 and swap 8 shr ;
\d clreol ( -- ) t-- | clear to eol on internal screen
: clreol ( -- ) [hex] 0920 color @ 80 cpos drop -
3 zeroes [hex] 10 bios 7 ndrop ;
\d clrscr ( -- ) t-- | clear to end of internal screen
: clrscr ( -- ) [hex] 0920 color @ 2000 cpos 80 * + -
3 zeroes [hex] 10 bios 7 ndrop ;
\d 'key ( -- a ) v-- | key hook
' (key) var 'key
\d kbmap ( c -- c' ) t-- | map raw key to key code
: kbmap ( c -- c' ) dup 328 = if drop k.up then
dup 336 = if drop k.down then
dup 333 = if drop k.right then
dup 331 = if drop k.left then ;
\d key ( -- c ) t-- | receive character from user tty
: key ( -- c ) 'key @ exec kbmap ;
\d '?key ( -- a ) v-- | ?key hook
' (?kbrdy) var '?key
\d ?key ( -- f ) t-- | key pending?
: ?key ( -- f ) '?key @ exec ;
\d (emit) ( c -- ) t-- | run emitc with default color
: (emit) ( c -- ) color @ emitc ;
\d 'emit ( -- a ) v-- | emit hook
' (emit) var 'emit
\d emit ( c -- ) t-- | transmit character to user tty
: emit ( c -- ) 'emit @ exec ;
\d usrtty ( -- a ) a-- | user tty routines
' (key) var usrtty ' (?kbrdy) , ' (emit) ,
\d space ( -- ) t-- | emit space character
: space ( -- ) bl emit ;
\d spaces ( n -- ) t-- | emit space characters
: spaces ( n -- ) for space next ;
\d tty! ( -- ) t-- | establish default tty hooks
: tty! ( -- ) usrtty @ 'key ! usrtty cell+ @ '?key !
usrtty cell+ cell+ @ 'emit ! ;
\d bs ( -- ) t-- | emit backspace character
: bs ( -- ) 8 emit ;
\d rubout ( -- ) t-- | emit destructive backspace
: rubout ( -- ) bs space bs ;
\d cr ( -- ) t-- | emit newline sequence
: cr ( -- ) 13 emit 10 emit ;
\d home ( -- ) t-- | move cursor to top/left corner
: home ( -- ) 1 1 cursor ;
\d page ( -- ) t-- | clear screen
: page ( -- ) home clrscr ;
\d so ( -- ) t-- | turn on standout mode
: so ( -- ) [hex] 70 color ! ;
\d se ( -- ) t-- | turn off standout mode
: se ( -- ) [hex] 07 color ! ;
\d type ( a n -- ) t-- | emit string
: type ( a n -- ) begin dup while
over c@ emit s+ repeat 2drop ;
defer quit
\d what? ( a -- ) t-- | emit string and trailing ? and cr
: what? ( a -- ) space count type [char] ? emit cr quit ;
\ ----- scanner -----
\
\d >buf ( -- a ) v-- | pointer to input buffer
0 var
>buf
\d >in ( -- a ) v-- | input pointer
0 var >in
\d >lim ( -- a ) v-- | pointer to input limit
0 var >lim
\d len ( -- a ) v-- | length of text in tib
0 var len
\d reread ( -- ) t-i | re-read input buffer
: reread ( -- ) >buf @ >in ! ;
\d reject ( -- ) t-i | un-read recently read character
: reject ( -- ) -1 >in +! ;
\d >in@ ( -- c ) t-i | read character from input buffer
: >in@ ( -- c ) >in @ >lim @ u>= if 0 exit then
>in @ c@ 1 >in +! ;
\d skip ( c -- ) t-i | skip characters in input buffer
: skip ( c -- ) begin >in@ over <> until drop reject ;
\d word ( c -- a ) t-i | extract word from input buffer
: word ( c -- a ) here >r 0 , 0 c, dup skip
begin >in@ 2dup <> over and while c, repeat
2drop here r@ - 3 - r@ 2+ c! r> dup h ! 2+ ;
\ ----- character functions -----
\
\d char ( -- c ) t-i | push character literal
: char ( -- c ) bl word 1+ c@ ;
\d [char] ( -- c ) tsi | compile character literal
: [char] ( -- c ) char lit ; syntax
\d >upper ( c -- c2 ) t-- | compile character literal
: >upper ( c -- c2 ) dup [char] a [char] z within if
32 - then ;
\d >lower ( c -- c2 ) t-- | convert character to lower case
: >lower ( c -- c2 ) dup [char] A [char] Z within if
32 + then ;
\d >visual ( c -- c2 ) t-- | replace unprintable characters
: >visual ( c -- c2 ) dup bl [char] ~ within not if
drop [char] . then ;
\ ----- string/memory functions -----
\
\d (skip) ( a -- a r ) t-- | skip over inline string literal
: (skip) ( a -- a r ) dup dup c@ + 1+ ;
\d (s") ( -- a ) t-- | runtime of s"
: (s") ( -- a ) r> (skip) >r ;
\d (save") ( -- a ) t-i | save string in lexicon
: (save") ( -- a ) here >in@ [char] " = if
here 0 , 0 c, h ! 0 else
reject [char] " word c@ then 3 + allot ;
\d s" ( -- a ) tsi | compile string literal
: s" ( -- a ) (save") ['] (s") swap ! ; syntax
\d (.") ( -- ) t-- | runtime of ."
: (.") ( -- ) r> (skip) >r count type ;
\d ." ( -- ) tsi | type inline string literal
: ." ( -- ) (save") ['] (.") swap ! ; syntax
\d (abort") ( a -- ) t-- | runtime of abort"
: (abort") ( a -- ) tty! r> (skip) >r what? ;
\d abort" ( -- ) tsi | print message and quit
: abort" ( -- ) (save") ['] (abort") swap ! ; syntax
\d upcase ( a -- ) t-- | convert string to upper case
: upcase ( a -- ) count begin dup while
over dup c@ >upper swap c! s+ repeat 2drop ;
\d locase ( a -- ) t-- | convert string to lower case
: locase ( a -- ) count begin dup while
over dup c@ >lower swap c! s+ repeat 2drop ;
\d blank ( a n -- ) t-- | fill memory with blanks
: blank ( a n -- ) bl fill ;
\d erase ( a n -- ) t-- | fill memory with zeroes
: erase ( a n -- ) 0 fill ;
\d cmove ( dst src n -- ) t-- | copy memory region
: cmove ( src dst n -- ) -rot 2dup u> if
rot <cmove else rot cmove> then ;
\d .( ( -- ) tsi | print execution time comment
: .( ( -- ) [char] ) word count type ; syntax
\d ( ( -- ) tsi | introduce parenthesized comment
: ( ( -- ) [char] ) word drop ; syntax
\d \ ( -- ) tsi | introduce comment to end of line
: \ ( -- ) >in @ b/r + b/r 1- inv and >in ! ; syntax
\d \d ( -- ) t-i | introduce documentation comment
: \d ( -- ) escape \ ;
\d \s ( -- ) t-i | introduce comment to end of screen
: \s ( -- ) 0 word drop ;
\ ----- more lexicon functions -----
\
\d create ( -- ) t-i | create lexicon entry
: create ( -- ) bl word dup locase ( w)
lexicon @ here ! here last !
here l>code 1- h ! ( w) c@ c,
232 ( call ) c, ['] (var) here 2+ - , ;
\d link ( -- ) t-- | link new entry into lexicon
: link ( -- ) last @ lexicon ! ;
\d find ( a -- 0|a -1 ) t-i | find code addr of lexicon entry
: find ( a -- 0|a -1 ) dup locase lexicon @ lookup dup if
swap l>code swap then ;
\d ' ( -- a ) t-i | force code address of lexicon entry
: (') ( -- a ) bl word dup find if nip else what? then ;
' (') is '
\d forget ( -- ) t-i | delete words from lexicon
: forget ( -- ) ' >link dup fence @ u<= if
abort" fence" then dup @ lexicon ! dup last ! h ! ;
\d empty ( -- ) t-- | forget all unprotected words
: empty ( -- ) here last @ begin dup while
dup @ fence @ u< if dup lexicon ! last ! h ! exit then
nip dup @ repeat 2drop ;
\d dict> ( -- ) t-- | begin new dictionary
: dict> ( -- ) last @ >dict ! ;
\d <dict ( -- ) t-i | delimit and define dictionary
: <dict ( -- ) create >dict @ , lexicon @ @ , link ;
\d show ( a -- ) t-- | show (activate) dictionary
: show ( a -- ) dup 2+ @ swap p>code >link @ ! ;
\d hide ( a -- ) t-- | hide (deactivate) dictionary
: hide ( a -- ) dup @ swap p>code >link @ ! ;
\ ----- definition words -----
\
\d var ( n -- ) t-i | define variable
: var ( n -- ) create , link ;
\d patch ( a -- a ) t-- | patch code field
: patch ( a -- a ) here - here cell- ! ;
\d const ( n -- ) t-i | define constant
: const ( n -- ) create ['] (const) patch , link ;
\d alias ( a -- ) t-i | define alias
: alias ( a -- ) create patch
233 ( jmp ) here 3 - c! link ;
\ ----- numeric i/o and converion -----
\
\d base ( -- a ) v-- | input/output radix
10 var base
\d hld ( -- a ) v-- | ptr to numeric conversion buffer
0 var hld
\d ?# ( c -- 0|n -1 ) t-- | test if character is a digit
: ?# ( c -- 0|n -1 ) dup [char] 0 [char] 9 within if
[char] 0 - true exit then
base @ 10