Hyperlinked SOL-86 OS

This is the source code to the full SOL-86 system. Primitives are written in machine language (hex code) and high-level definitions are in SOL, a stack-oriented (FORTH-like) language. The entire system can be compiled to stand-alone binary by a 600-line compiler in T3X. The entire SOL-86 system can be downloaded here.

\ SOL Kernel for the 8086, Version 0.8.0
\ By Nils M Holm, 2001,2004,2009

\ 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
34 const b.init

\d b.fbl ( -- n ) c-- | free list block
33 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 > if  dup [char] a [char] f within if
    [char] W - true exit then  then  drop false ;

\d ?num ( a -- 0|n -1 ) t-- | test if string is numeric
: ?num ( a -- 0|n -1 ) 0 >r  count begin  dup while
    over c@ ?# not if  2drop  rdrop  false exit then
    r> base @ * + >r  s+
  repeat  2drop  r> true ;

\d pad ( -- a ) a-- | scratch pad address
: pad ( -- a ) here 128 + ;

\d <# ( n m -- n m ) t-- | begin pictured conversion
: <# ( n m -- n m ) pad 128 +  hld ! ;

\d hold ( c -- ) t-- | insert character into scratch pad
: hold ( c -- ) hld @ c!  -1 hld +! ;

\d sign ( n m -- n m ) t-- | hold minus if n negative
: sign ( n m -- n m ) over 0< if  [char] - hold then ;

\d # ( n -- m ) t-- | convert and hold digit
: # ( n -- m ) base @ u/mod  [char] 0 +
  dup [char] 9 > if  39 + then  hold ;

\d #s ( n -- 0 ) t-- | convert and hold remaining digits
: #s ( n -- 0 ) begin  # dup 0= until ;

\d #> ( n n -- a n ) t-- | end pictured conversion
: #> ( n n -- a n ) 2drop  hld @ 1+  pad 128 + hld @ - ;

\d . ( n -- ) t-- | print signed number
: . ( n -- ) space  dup abs <# #s sign #> type ;

\d u. ( u -- ) t-- | print unsigned number
: u. ( u -- ) space  dup <# #s #> type ;

\d .pad ( l a n -- a n ) t-- | print l-n spaces if l-n>0
: .pad ( l a n -- a n ) rot over -  dup 0> if
    spaces else  drop then ;

\d .r ( n len -- ) t-- | print signed number w/padding
: .r ( n len -- ) swap  dup abs <# #s sign #> .pad type ;

\d u.r ( u len -- ) t-- | print unsigned number w/padding
: u.r ( u len -- ) swap  dup <# #s #> .pad type ;

\d ? ( a -- ) t-- | print value of cell
: ? ( a -- ) @ . ;

\d u? ( a -- ) t-- | print unsigned value of cell
: u? ( a -- ) @ u. ;

\d c? ( a -- ) t-- | print value of character cell
: c? ( a -- ) c@ . ;

\d bin! ( -- ) t-- | set numeric base to 2
: bin! ( -- ) 2 base ! ;

\d dec! ( -- ) t-- | set numeric base to 10
: dec! ( -- ) 10 base ! ;

\d hex! ( -- ) t-- | set numeric base to 16
: hex! ( -- ) 16 base ! ;

\d #in ( -- n ) t-i | scan and translate number
: #in ( -- n ) bl word  ?num not if  0 then ;

\d nbase ( n -- n ) t-i | push base-n literal
: nbase ( n -- n ) base @ swap  base !
  bl word  ?num not if
     base !  abort" bad number" then  swap base ! ;

\d (nbase) ( n -- ) t-i | runtime of '[bin]' and friends
: (nbase) ( n -- ) nbase lit ;

\d [bin] ( -- n ) tsi | compile binary literal
: [bin] ( -- n ) 2 (nbase) ; syntax

\d [dec] ( -- n ) tsi | compile decimal literal
: [dec] ( -- n ) 10 (nbase) ; syntax

\d [hex] ( -- n ) tsi | compile hexa-decimal literal
: [hex] ( -- n ) 16 (nbase) ; syntax

\d bin ( -- n ) t-i | push binary number
: bin ( -- n ) 2 nbase ;

\d dec ( -- n ) t-i | push decimal number
: dec ( -- n ) 10 nbase ;

\d hex ( -- n ) t-i | push hexa-decimal number
: hex ( -- n ) 16 nbase ;

\ ----- disk parameter area -----
\
\d f0dpa ( -- a ) a-- | floppy disk 0 parmeter area
0 var f0dpa  80 , 2 , 18 , 512 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,

\d f1dpa ( -- a ) a-- | floppy disk 1 parmeter area
1 var f1dpa  80 , 2 , 18 , 512 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,

\d hdpa ( -- a ) a-- | hard disk parmeter area
128 var hdpa  989 , 10 , 34 , 512 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,

\d dpa ( -- a ) v-- | disk parameter array
0 var dpa

\d dp.unit ( -- a ) t-- | dpa, unit no
: dp.unit ( -- a ) dpa @ ;

\d dp.ncyl ( -- a ) t-- | dpa, # of cylinders/disk
: dp.ncyl ( -- a ) dpa @ 2 + ;

\d dp.nhed ( -- a ) t-- | dpa, # of heads/cylinders
: dp.nhed ( -- a ) dpa @ 4 + ;

\d dp.nsec ( -- a ) t-- | dpa, # of sectors/heads
: dp.nsec ( -- a ) dpa @ 6 + ;

\d dp.nbps ( -- a ) t-- | dpa, # of bytes/sector
: dp.nbps ( -- a ) dpa @ 8 + ;

\d dp.base ( -- a ) t-- | dpa, base cylinder
: dp.base ( -- a ) dpa @ 10 + ;

\d dp.cyl ( -- a ) t-- | dpa, current cylinder
: dp.cyl  ( -- a ) dpa @ 12 + ;

\d dp.hed ( -- a ) t-- | dpa, current head
: dp.hed  ( -- a ) dpa @ 14 + ;

\d dp.sec ( -- a ) t-- | dpa, current sector
: dp.sec  ( -- a ) dpa @ 16 + ;

\d dp.blk ( -- a ) t-- | dpa, src/dst block
: dp.blk  ( -- a ) dpa @ 18 + ;

\d dp.buf ( -- a ) t-- | dpa, buffer address
: dp.buf  ( -- a ) dpa @ 20 + ;

\d dp.op ( -- a ) t-- | dpa, opcode
: dp.op   ( -- a ) dpa @ 22 + ;

\d do.read ( -- n ) c-- | disk read opcode
hex 0201 const do.read

\d do.write ( -- n ) c-- | disk write opcode
hex 0301 const do.write

\ ----- low level block i/o -----
\
\d ?i/o ( f -- ) t-- | test for i/o error
: ?i/o ( f -- ) if  abort" i/o error" then ;

\d dkaddr ( -- ) t-- | convert linear sector to disk addr
: dkaddr ( -- ) dp.blk @  dp.nhed @  dp.nsec @ *
  u/mod swap  dp.base @ +  dp.cyl !
  dp.nsec @ u/mod  1+ dp.sec !  dp.hed ! ;

\d dkio ( -- f ) t-- | run disk i/o request
: dkio ( -- f ) dkaddr  dp.op @  dp.buf @
  dp.sec @  dp.cyl @ 8 shl or  dp.cyl @ 2 shr [hex] c0 and or
  dp.unit @ dp.hed @ 8 shl or  0 0 [hex] 13 bios
  >r 6 ndrop r>  f.c and ?i/o ;

\d s/blk ( -- n ) t-- | number of sectors per block
: s/blk ( -- n ) b/blk  dp.nbps @  / ;

\d dsk-i/o ( blk -- ) t-- | disk i/o request handler
: dsk-i/o ( blk -- ) s/blk *  s/blk 1- 0 do
    dup i +  dp.blk !  dkio  dp.nbps @  dp.buf +!
  loop  drop ;

\d 'read ( -- a ) v-- | block read hook
0 var 'read

\d 'write ( -- a ) v-- | block write hook
0 var 'write

\d dskrd ( blk a -- ) t-- | read disk block
: dskrd ( blk a -- ) dp.buf !  do.read dp.op !  dsk-i/o ;

\d dskwr ( blk a -- ) t-- | write disk block
: dskwr ( blk a -- ) dp.buf !  do.write dp.op !  dsk-i/o ;

\d (dsk!) ( dpa -- ) t-- | select disk device w/o sync
: (dsk!) ( dpa -- ) dpa !  b.fbl fbl dskrd
  ['] dskrd 'read !  ['] dskwr 'write ! ;

\d dsk! ( dpa -- ) t-- | select disk device
: dsk! ( dpa -- ) b.fbl fbl dskwr  (dsk!) ;

\ ----- abstract block i/o -----
\
\d blk ( -- a ) v-- | block currently in dtb
-1 var blk

\d dirty ( -- a ) v-- | block in dtb changed?
false var dirty

\d safe ( -- a ) v-- | safe mode (auto-sync free list)
false var safe

\d read ( blk a -- ) t-- | read block
: read ( blk a -- ) 'read @ exec ;

\d write ( blk a -- ) t-- | write block
: write ( blk a -- ) 'write @ exec ;

\d flush ( -- ) t-- | re-write block in dtb, if dirty
: flush ( -- ) dirty @ if  blk @ dtb write then
  false dirty ! ;

\d update ( -- ) t-- | mark block in dtb dirty
: update ( -- ) true dirty ! ;

\d discard ( -- ) t-- | clear block buffer
: discard ( -- ) -1 blk !  false dirty ! ;

\d block ( blk -- a ) t-- | read block into dtb
: block ( blk -- a ) flush  dup blk @ = if  drop else
    dup dtb read  blk ! then  dtb ;

\d save ( -- ) t-- | save kernel
: save ( -- ) 1280  16 1 do  i over write  b/blk +
    loop  drop ;

\d src@ ( -- src[4] ) t-- | save current input parameters
: src@ ( -- src[4] ) blk @  >buf @  >lim @  >in @ ;

\d src! ( src[4] -- ) t-- | restore input parameters
: src! ( src[4] -- ) >in !  >lim !  >buf !
  dup -1 = if  blk ! else  block drop then ;

\d sync ( -- ) t-- | update free list
: sync ( -- ) b.fbl fbl write ;

\d auto-sync ( -- ) t-- | automatically update free list
: auto-sync ( -- ) safe @ if  sync then ;

\d fbaddr ( blk -- a m ) t-- | get freelist bit address
: fbaddr ( blk -- a m ) 8 /mod  1 swap shl  swap fbl + swap ;

\d freebit ( a m -- a m f ) t-- | extract bit from free list
: freebit ( a m -- a m f ) over c@ over and ;

\d ?used ( blk -- f ) t-- | test block allocation
: ?used ( blk -- f ) fbaddr swap c@ and 0= not ;

\d dsize ( -- n ) t-- | compute #blocks on disk
: dsize ( -- n )
  dp.ncyl @ dp.nhed @ * dp.nsec @ * 2 /  8192 max ;

\d nfree ( size -- n ) t-- | retrieve number of free blocks
: nfree ( size -- n ) dsize  dup for
    i 1- ?used if  1- then  next ;

\d allocate ( blk -- ) t-- | allocate disk block
: allocate ( blk -- ) fbaddr
  freebit if  abort" used block" then
  over c@ or  swap c!  auto-sync ;

\d release ( blk -- ) t-- | release block to free list
: release ( blk -- ) fbaddr
  freebit 0= if  abort" free block" then
  inv over c@ and  swap c!  auto-sync ;

\d newblk ( -- blk ) t-- | find and allocate free block
: newblk ( -- blk ) fbl b/blk + 1-  fbl  do
    i c@ [hex] ff <> if
      i fbl - 8 *  i c@ bsz +  dup allocate
      auto-sync  unloop  exit  then
  loop  abort" disk full" ;

\d index ( lo hi -- ) t-- | list block headings
: index ( lo hi -- ) swap do  i block drop
  dtb c@  [char] ( = if
    cr  i 5 .r  space  dtb b/r type  then  loop ;

\ ----- compilers -----
\
\d ; ( -- ) ts- | delimit colon definition
: ; ( -- ) compile exit  link  rdrop ; syntax

\d :: ( -- ) t-i | create colon header
: :: ( -- ) create  ['] (:) patch ;

\d ] ( -- ) t-i | thread compiler
: ] ( -- ) begin  bl word  dup c@ 0= if  drop exit then
    dup find if  dup >name c@ 128 and if
        nip exec else  , drop then  else
      dup ?num if  lit drop else  what? then  then  again ;

\d [ ( -- ) ts- | exit from thread compiler
: [ ( -- ) rdrop ; syntax

\d : ( -- ) t-i | introduce colon definition
: : ( -- ) ::  ] ;

\d (defer) ( -- ) t-- | deferred word handler
: (defer) ( -- ) abort" deferred" ;

\d defer ( -- ) t-i | create deferred definition
: defer ( -- ) ::  compile (defer)  escape ; ;

\d is ( a -- ) t-i | backpatch deferred definition
: is ( a -- ) ' >pfa ! ;

\d h] ( n -- ) t-i | base-16 machine code compiler
: h] ( -- ) hex!  begin bl word
    dup c@ 0= if  drop dec! exit then
    dup ?num if  c, drop else  dup find if
      nip exec else  what? then  then  again ;

\d :h ( -- ) t-i | compile hex code
: :h ( -- ) create  here p>code h !  h] ;

\d next, ( -- ) t-- | compile 'next' primitive
: next, ( -- ) 173 c, ( lodsw ) 255 c, 224 c, ( jmp ax ) ;

\d next; ( n -- ) t-- | compile 'next' and exit :h
: next; ( n -- ) next,  dec!  link  rdrop ;

\ ----- line editor -----
\
\d q.back ( -- ) t-- | query: move backward
: q.back ( -- ) >in @  >buf @ > if
    -1 >in +!  bs  then ;

\d q.fwd ( -- ) t-- | query: move forward
: q.fwd ( -- ) >in @  >buf @ len @ + < if
    >in @ c@ emit  1 >in +!  then ;

\d q.len ( -- n ) t-- | query: length of rest of line
: q.len ( -- n ) len @ >in @ - >buf @ + ;

\d q.type ( f -- ) t-- | query: type rest of line
: q.type ( f -- ) >in @  q.len type  space bs  ( f ) if
    q.len  ?dup if  for bs next then  then ;

\d q.ins ( c -- ) t-- | query: insert and emit character
: q.ins ( c -- ) >buf @ len @ +  >lim @ u>=  if
    drop exit then
  >in @  dup 1+  q.len ?dup if  cmove> else  2drop then
  dup >in @ c!  1 >in +!  1 len +!  emit ;

\d q.del ( -- ) t-- | query: delete character left
: q.del ( -- ) >in @ >buf @ u<= ?exit  len @ 1 < ?exit
  >in @  dup 1-  q.len <cmove  bs  -1 >in +!  -1 len +! ;

\d q.eol ( -- ) t-- | query: goto eol
: q.eol ( -- ) 0 q.type  >buf @ len @ + >in ! ;

\d q.edit ( n -- ) t-- | interactive line editor
: q.edit ( n -- ) len !  q.eol  begin  key  case
    dup k.left =  => drop  q.back ;;
    dup k.right = => drop  q.fwd ;;
    dup 1 =       => drop  begin >in @ >buf @  > while
                       q.back repeat ;;
    dup 5 =       => drop  q.eol ;;
    dup 8 =       => drop  q.del 1 q.type ;;
    dup 13 =      => drop  q.eol  >buf @ len @ +  >in !
                     0  >in @  c!  1 >in +!  exit ;;
    dup 21 =      => drop  q.eol ."  ^U" cr
                     >buf @ >in !  0 len ! ;;
               else> q.ins 1 q.type
  end  again ;

\d query ( -- ) t-- | read string into tib
: query ( -- ) tib >buf !  tib >in !  tib b/r + >lim !
  0 q.edit ;

\d equery ( -- ) t-- | edit string
: equery ( -- ) >buf @  dup dup b/r + 1-  swap do
    i c@  bl <> if  drop i then  loop  >buf @ -
  dup if 1+ then  q.edit ;

\ ----- interpreter -----
\
\d .ok ( -- ) t-- | emit ok prompt
: .ok ( -- ) ."  ok" cr ;

\d ?stack ( -- ) t-- | check for stack limit violations
: ?stack ( -- ) sp@ s0 cell- u>  sp@ s0 512 - u<= or
  rp@ r0 cell- u> or  rp@ r0 512 - u<= or  if
    abort" stack" then ;

\d interpret ( -- ) t-i | interpreter
: interpret ( -- ) begin  bl word dup c@ while
    dup find if  nip  exec else
      dup ?num 0= if what? then  nip then
    ?stack  repeat  drop ;

\d load ( n -- ) t-- | load and interpret block
: load ( n -- ) >r src@  r> block
  dup >buf !  dup >in !  b/blk + >lim !
  interpret  src! ;

\ ----- top level loop -----
\
\d quit ( -- ) t-i | top level loop
: (quit) ( -- ) r0 rp!  s0 sp!  begin
    tty!  query  >in @ >lim !  reread
    interpret .ok  again ;
' (quit) is quit

\ ----- tools -----
\
\d .s ( -- ) t-- | print stack
: .s ( -- ) s0 cell- cell- begin  dup sp@ cell+ u> while
   dup @ . cell- repeat  drop ;

\d parse ( a n c -- a ) t-i | extract word, c = delimiter
: parse ( a n c -- a ) >in @ >r  >lim @ >r
  -rot over + >lim !  >in !  word
  r> >lim !  r> >in ! ;

\d .w ( a -- ) t-- | print name of word
: .w ( a -- ) >name count 127 and type ;

\d words ( -- ) t-- | print n-words chunks of lexicon
: words ( -- ) 100  lexicon @ begin  dup while
    dup l>code space .w  swap 1- swap over  0= if
      key 13 <> if  2drop exit then  swap drop 100 swap
    then  @ repeat  2drop ;

\d hdump ( a -- ) t-- | print 16-byte hex dump
: hdump ( a -- ) base @ swap  hex!  15 0 do
    dup i + c@ 3 u.r  i 7 = if  space then
  loop  drop  base ! ;

\d cdump ( a -- ) t-- | print 16-character ascii dump
: cdump ( a -- ) 15 0 do
    dup i + c@ >visual emit loop  drop ;

\d dump ( a n -- ) t-- | print hex/char dump
: dump ( a n -- ) base @ -rot  hex!   16 /  0 do
    cr  dup  i 16 * +  dup 4 u.r space
    dup hdump  2 spaces  cdump  loop  drop  base ! ;

\ ----- block editor -----
\
\d .l ( a n -- ) t-- | print n'th line of buffer at a
: .l ( a n -- ) dup 1+ 2 .r space
  b/r * + b/r type [char] | emit ;

\d list ( blk -- ) t-- | list content of block
: list ( blk -- ) block drop  15 0 do
    cr  dtb i .l  loop ;

\d p ( -- ) t-- | list most recently accessed block
: p ( -- ) blk @ list ;

\d rest ( a n -- a' n' ) t-- | compute rest of block
: rest ( a n -- a' n' ) dup  b/r *  b/blk swap -  -rot
  b/r * +  swap ;

\d delete ( a n -- ) t-- | delete line of block
: delete ( a n -- ) over >r  rest
  over b/r +  -rot  b/r - cmove
  r> r/blk 1- b/r * +  b/r  blank ;

\d insert ( a n -- ) t-- | insert blank line into block
: insert ( a n -- ) rest  dup b/r <> if over >r
    over b/r +  swap  b/r - cmove  r> else  drop then
  b/r blank ;

\d del ( n -- ) t-- | delete line n of current block
: del ( n -- ) dtb swap 1- delete ;

\d ins ( n -- ) t-- | insert blank line n into current block
: ins ( n -- ) dtb swap 1- insert ;

\d copy ( a n -- ) t-- | copy line n from current block
: copy ( a n -- ) 1- b/r * dtb +  swap  b/r cmove ;

\d subst ( a n -- ) t-- | substitute line n of current block
: subst ( a n -- ) 1- b/r * dtb +  b/r cmove ;

\d 0pad ( a -- ) t-- | pad 0-terminated record with blanks
: 0pad ( a -- ) dup >r b/r  0 cscan ?dup if
      dup r@ - b/r swap - blank then  rdrop ;

\d repl ( n -- ) t-- | replace line in current block
: repl ( n -- ) dup >r 1-  cr  dtb swap .l  cr  3 spaces
  >in @  >lim @  >buf @
  pad >in !  pad >buf !  pad b/r + >lim !
  pad r@ copy  equery  pad c@ if
    pad 0pad  pad r@ subst then
  >buf !  >lim !  >in !  rdrop ;

\ ----- linked block support -----
\
\d <l ( -- a ) v-- | previous block in l-block list
0 var <l

\d l> ( -- a ) v-- | next block in l-block list
0 var l>

\d (l ( -- ) t-i | l-block header
: (l ( -- ) base @ dec!  dtb 2+ >in !  bl word ?num if
    <l !  bl word ?num if
      l> !  [char] ) word drop  base !  exit  then
  then  base !  abort"  bad (l header" ;

\d l@ ( n -- 0|n -1 ) t-- | extract field from (l header
: l@ ( n -- 0|n -1 ) dtb +  10 bl parse  ?num ;

\d lhdr ( -- f ) t-- | test and read l-block header
: lhdr ( -- f ) 0 <l !  0 l> !
  dtb c@  [char] ( <>  dtb 1+ c@ [char] l <>  or if  0 else
    3 l@ if  <l ! then  9 l@ if  l> ! then  1 then ;

\d ?lhdr ( -- ) t-- | force l-block header
: ?lhdr ( -- ) lhdr ?exit  abort"  no (l header" ;

\d l! ( blk off -- ) t-- | link block at offset in l-hdr
: l! ( blk off -- ) dtb + >r  dup <# # # # # # #>
  r> swap  cmove ;

\d 2l! ( prev next -- ) t-- | update l-block links
: 2l! ( prev next -- ) 9 l!  3 l! ;

\d lindex ( lo hi -- ) t-- | list l-block headings
: lindex ( lo hi -- ) swap do  i block drop  lhdr if
      <l @ 0= if  cr  i 5 .r  space  dtb b/r type then
    then  loop ;

\d lload ( blk -- ) t-- | load l-blocks
: lload ( blk -- ) >r src@ r>  begin  block
    ?lhdr  dup >buf !  dup >in !  b/blk + >lim !
    interpret  l> @  dup 0= until  drop  src! ;

\d lclear ( blk -- ) t-- | create initial l-block
: lclear ( blk -- ) block b/blk blank
  s" (l 00000 00000  )" count  dtb swap  cmove ;

\d lblock ( prev next blk -- ) t-- | insert empty l-block
: lblock ( prev next blk -- ) dup lclear  -rot
  2dup 2l!  update  ?dup if
    block drop  ?lhdr  over l> @  2l!  update  then
  ?dup if
    block drop  ?lhdr  <l @ over  2l!  update  then
  block drop ;

\d p<l ( -- a ) v-- | old <l, used to unlink l-blocks
0 var p<l

\d pl> ( -- a ) v-- | old l>, used to unlink l-blocks
0 var pl>

\d lfree ( blk -- ) t-- | unlink l-block
: lfree ( blk -- ) block drop  ?lhdr  dtb b/r blank  update
  <l @ p<l !  l> @ pl> !  p<l @ ?dup if
    block drop  ?lhdr  <l @ pl> @ 2l!  update then
  pl> @ ?dup if
    block drop  ?lhdr  p<l @ l> @ 2l!  update then ;

\ ----- trap handler -----
\
\d trap ( -- ) t-- | default trap handler
: trap ( -- ) abort" trap" ;

\d trapinit ( -- ) t-- | init trap vectors
: trapinit ( -- ) nointr  0 20 erase
  ['] trap  dup 0 !  dup 4 !  dup 8 !  dup 12 !  16 !  intr ;

\ ----- startup and shutdown routines -----
\
\d bye ( -- ) t-- | shutdown routine
: bye ( -- ) flush  sync  ."  bye!" cr  halt ;

\d sol ( -- ) t-- | startup routine
: sol ( -- )
  trapinit
  cr ." SOL-86 version 0.8.0 by Nils M Holm, 2009" cr cr
  case bdev @ 0=    => f0dpa (dsk!) ;;
       bdev @ 1 =   => f1dpa (dsk!) ;;
       bdev @ 128 = => hdpa (dsk!) ;;
                 else> ." no boot device" halt
  end  b.init load  quit ;

\ ----- setup -----
\
' sol 'sol !
' sol >link lexicon !
' sol >link last !
' sol >link fence !
here h !