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 stand-alone system can then re-compile itself. 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 !