( This file is part of muFORTH: http://pages.nimblemachines.com/muforth
Copyright 2002-2008 David Frech. All rights reserved, and all wrongs
reversed. (See the file COPYRIGHT for details.)
( draw the colorForth icons/characters)
comment %%
( Note: PROT_READ is 1)
: mmap-dev ( #blocks - a) open-file 1 rot Ki mmap ; %%
z" cf/color.com"
-- z" /home/david/Chuck/COLOR.COM.9sep"
-- z" /home/david/Chuck/colorForth.dist"
-- z" /tmp/cf"
-- 162 mmap-dev /dev/fd0
r/o open-file mmap-file swap nip constant |cf
: block Ki |cf + ;
: c@+ ( a - a+ byte) dup 1+ swap c@ ;
: @+ dup cell+ swap @ ;
: w@+ c@+ ( hi) 8 << swap c@+ ( lo) rot + ;
: dot "8000 and if char # ^ then bl ;
: .16 cr 16 for dup dot dup emit emit 2* next drop ;
: .24 cr 24 for w@+ .16 next ;
: icon ( n - a) 48 * 12 block + ;
-- : icons ( n first) icon swap for .24 next drop ;
comment %%
: raw ; ( from when I could change tty modes)
: cooked ; %%
: = xor 0= ;
: done? tty raw key tty cooked char q = ;
: icons ( first)
dup icon begin .24 over space . 1 u+ done? until drop ;
: _chs for dup emit 1+ next cr ;
: .64 64 _chs ;
: .32 32 _chs ;
: chars 32 .32 .64 .64 .64 drop ;
( terminal ESC sequences)
: <esc <# char m hold ;
: esc> char [ hold ctrl [ hold #> type ;
( colored and attributed text)
comment %%
: color ctrl [ emit ( esc) char [ emit 30 + u. char m emit ;
: _color drop space ; %%
: attrib <esc #s esc> ;
: color ( foregd) 0 attrib 30 + attrib space ;
( : bright 1 attrib ;)
: bright char " emit ; ( bright yellow and green hard to read on white bg)
: black 0 color ;
: red 1 color ;
: green 2 color ;
: yellow 3 color ;
: blue 4 color ;
: magenta 5 color ;
: cyan 6 color ;
: _white 7 color ; ( for white-on-black)
-- : white _white ;
: white black ; ( for xterms and suchlike)
white
( printing source blocks)
variable case
: lc z" rtoeanismcylgfwdvpbhxuq0123456789j-k.z/;:!+@*,?" case ! ;
: uc z" RTOEANISMCYLGFWDVPBHXUQ0123456789J-K.Z/;:!+@*,?" case ! ;
: map case @ + c@ ;
: .4 swap 4 << swap 28 >> 7 and ;
: .5 swap 5 << swap 28 >> 7 and 8 + ;
: .7 swap 7 << swap 26 >> 31 and 16 + ;
: unpack dup dup 0< if 2* dup 0< if .7 ^ then .5 ^ then .4 ;
: 1char unpack map emit ;
: chars begin dup while 1char repeat drop ;
: .word lc chars ;
: .WORD uc chars ;
: .Word uc 1char .word ;
( Support for our bizarre little state-machine/co-routine/continuation gizmo)
variable 'co
( Note the dual nature of these two routines!)
: suspend pop 'co ! ; ( return from co-routine)
: resume 'co @ push ; ( call to co-routine)
defer ->format
variable #used ( # of cells in this block)
: tally 1 #used +! ; ( count it)
: ?tally =if tally then ; ( count it only if non-zero)
( numbers, with auto-radix)
variable auto-radix ( so we don't clobber muforth's)
: .d (.) type ;
: .h bright hex (u.) decimal type ;
: .radix auto-radix @ "10 and if .h ^ then .d ;
: .num auto-radix ! suspend tally .radix ->format ;
: .short dup auto-radix ! 5 >> .radix ;
( kinds of words; "xW" names are from cf source - don't blame me!)
: ign .word ; ( ignored - doesn't change color)
: rW cr red .word ;
: wW yellow .word ; ( "white")
: gW green .word ;
: mW cyan .word ; ( macro)
: text white .word ;
: Text white .Word ;
: TEXT white .WORD ;
: nW yellow .num ;
: gnW green .num ;
: sW yellow .short ;
: gsW green .short ;
: var cr magenta .word suspend tally dup green .d green .h ->format ;
( show value in hex & dec)
-:
suspend ?tally
dup -16 and swap 15 and jump
ign wW nW rW
gW gnW gsW mW
sW text Text TEXT
var ign ign ign [ is ->format
( kinds of words; "xW" names are from cf source - don't blame me!)
( annotate with type info as well as color)
: .type
0 <# bl hold char ] hold hex # decimal char [ hold bl hold #> type ;
: ign .type .word ; ( ignored - doesn't change color)
: rW cr red .type .word ;
: wW yellow .type .word ; ( "white")
: gW green .type .word ;
: mW cyan .type .word ; ( macro)
: text white .type .word ;
: Text white .type .Word ;
: TEXT white .type .WORD ;
: nW yellow .type .num ;
: gnW green .type .num ;
: sW yellow .type .short ;
: gsW green .type .short ;
: var cr magenta .type .word
suspend tally dup green .d green .h ->format ;
( show value in hex & dec)
-:
suspend ?tally
dup -16 and swap 15 and dup jump
ign wW nW rW
gW gnW gsW mW
sW text Text TEXT
var ign ign ign [ is ->format
( kinds of words; "xW" names are from cf source - don't blame me!)
( annotate with type info but no color - suitable for reading back in and
converting back to colorforth source.)
variable _type
: 0type bl _type ! ;
: .type
space _type @ over _type ! xor if _type @ emit space then ;
: red char : .type ;
: green char ] .type ;
: yellow char [ .type ;
: magenta char @ .type ;
: cyan char \ .type ;
: white char ( .type ;
( kinds of words; "xW" names are from cf source - don't blame me!)
: ign .word ; ( ignored - doesn't change color)
: rW cr red .word ;
: wW yellow .word ; ( "white")
: gW green .word ;
: mW cyan .word ; ( macro)
: text white .word ;
: Text white .Word ;
: TEXT white .WORD ;
: nW yellow .num ;
: gnW green .num ;
: sW yellow .short ;
: gsW green .short ;
: var cr magenta .word suspend tally dup green .d green .h ->format ;
( show value in hex & dec)
-:
suspend ?tally
dup -16 and swap 15 and jump
ign wW nW rW
gW gnW gsW mW
sW text Text TEXT
var ign ign ign [ is ->format ( resolve forward ref)
( We'd like to do "256 for ... next" but since two kinds of words - full-
length numbers and variables - use an extra cell, it doesn't work. They
read an extra cell each, and we read into the next block. In other words,
instead of doing 256 @+'s we do 256+vars+nums.
We could fix this by going to a more complicated arrangement - essentially
a state machine, where every type returns a next state. This way normal
["single-cell"] words would return the normal "format" state; variables
and nums would return the state that would complete them. Then we could
put the fetching at the top-level and properly do "256 for @+ foo next".
That would be good. If a little strange and hard to read. But that's what
this file does!)
: .block 0 #used ! 0type ->format block 256 for @+ resume next drop ;
: header cr cr ." -*- Block " . ." -*-" cr ;
: footer cr cr ." (" #used @ dup (.) type ." /256 : "
100 256 */ (.) type ." % full)" ;
: sh decimal dup header .block ( white) footer ;
: shs ( n) begin dup sh 1+ done? until ;
|