Changeset View
Changeset View
Standalone View
Standalone View
stand/forth/support.4th
Show First 20 Lines • Show All 184 Lines • ▼ Show 20 Lines | : strchr { addr len c -- addr' len' } | ||||
while | while | ||||
addr c@ c = if addr len exit then | addr c@ c = if addr len exit then | ||||
addr 1 + to addr | addr 1 + to addr | ||||
len 1 - to len | len 1 - to len | ||||
repeat | repeat | ||||
0 0 | 0 0 | ||||
; | ; | ||||
: strspn { addr len addr1 len1 | paddr plen -- addr' len' } | |||||
begin | |||||
len | |||||
while | |||||
addr1 to paddr | |||||
len1 to plen | |||||
begin | |||||
plen | |||||
while | |||||
addr c@ paddr c@ = if addr len exit then | |||||
paddr 1+ to paddr | |||||
plen 1- to plen | |||||
repeat | |||||
addr 1 + to addr | |||||
len 1 - to len | |||||
repeat | |||||
0 0 | |||||
; | |||||
: s' \ same as s", allows " in the string | : s' \ same as s", allows " in the string | ||||
[char] ' parse | [char] ' parse | ||||
state @ if postpone sliteral then | state @ if postpone sliteral then | ||||
; immediate | ; immediate | ||||
: 2>r postpone >r postpone >r ; immediate | : 2>r postpone >r postpone >r ; immediate | ||||
: 2r> postpone r> postpone r> ; immediate | : 2r> postpone r> postpone r> ; immediate | ||||
: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate | : 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate | ||||
: getenv? getenv -1 = if false else drop true then ; | : getenv? getenv -1 = if false else drop true then ; | ||||
\ execute xt for each device listed in console variable. | |||||
\ this allows us to have device specific output for logos, menu frames etc | |||||
: console-iterate { xt | caddr clen taddr tlen -- } | |||||
\ get current console and save it | |||||
s" console" getenv | |||||
['] strdup catch if 2drop exit then | |||||
to clen to caddr | |||||
clen to tlen | |||||
caddr to taddr | |||||
begin | |||||
tlen | |||||
while | |||||
taddr tlen s" , " strspn | |||||
\ we need to handle 3 cases for addr len pairs on stack: | |||||
\ addr len are 0 0 - there was no comma nor space | |||||
\ addr len are x 0 - the first char is either comma or space | |||||
\ addr len are x y. | |||||
2dup + 0= if | |||||
\ there was no comma nor space. | |||||
2drop | |||||
taddr tlen s" console" setenv | |||||
xt execute | |||||
0 to tlen | |||||
else dup 0= if | |||||
2drop | |||||
else | |||||
dup ( taddr' tlen' tlen' ) | |||||
tlen swap - dup | |||||
0= if \ sequence of comma and space? | |||||
drop | |||||
else | |||||
taddr swap s" console" setenv | |||||
xt execute | |||||
then | |||||
to tlen | |||||
to taddr | |||||
then then | |||||
tlen 0> if \ step over separator | |||||
tlen 1- to tlen | |||||
taddr 1+ to taddr | |||||
then | |||||
repeat | |||||
caddr clen s" console" setenv \ restore console setup | |||||
caddr free drop | |||||
; | |||||
\ determine if a word appears in a string, case-insensitive | \ determine if a word appears in a string, case-insensitive | ||||
: contains? ( addr1 len1 addr2 len2 -- 0 | -1 ) | : contains? ( addr1 len1 addr2 len2 -- 0 | -1 ) | ||||
2 pick 0= if 2drop 2drop true exit then | 2 pick 0= if 2drop 2drop true exit then | ||||
dup 0= if 2drop 2drop false exit then | dup 0= if 2drop 2drop false exit then | ||||
begin | begin | ||||
begin | begin | ||||
swap dup c@ dup 32 = over 9 = or over 10 = or | swap dup c@ dup 32 = over 9 = or over 10 = or | ||||
over 13 = or over 44 = or swap drop | over 13 = or over 44 = or swap drop | ||||
Show All 14 Lines | : contains? ( addr1 len1 addr2 len2 -- 0 | -1 ) | ||||
repeat | repeat | ||||
2drop 2drop false | 2drop 2drop false | ||||
; | ; | ||||
: boot_serial? ( -- 0 | -1 ) | : boot_serial? ( -- 0 | -1 ) | ||||
s" console" getenv dup -1 <> if | s" console" getenv dup -1 <> if | ||||
s" comconsole" 2swap contains? | s" comconsole" 2swap contains? | ||||
else drop false then | else drop false then | ||||
s" boot_serial" getenv dup -1 <> if | \ s" boot_serial" getenv dup -1 <> if | ||||
swap drop 0> | \ swap drop 0> | ||||
else drop false then | \ else drop false then | ||||
or \ console contains comconsole ( or ) boot_serial | \ or \ console contains comconsole ( or ) boot_serial | ||||
s" boot_multicons" getenv dup -1 <> if | \ s" boot_multicons" getenv dup -1 <> if | ||||
swap drop 0> | \ swap drop 0> | ||||
else drop false then | \ else drop false then | ||||
or \ previous boolean ( or ) boot_multicons | \ or \ previous boolean ( or ) boot_multicons | ||||
; | |||||
: framebuffer? ( -- t ) | |||||
s" console" getenv | |||||
2dup s" efi" compare 0<> >r | |||||
s" vidconsole" compare 0<> r> and if | |||||
FALSE exit | |||||
then | |||||
s" screen.depth" getenv? | |||||
; | ; | ||||
\ Private definitions | \ Private definitions | ||||
vocabulary support-functions | vocabulary support-functions | ||||
only forth also support-functions definitions | only forth also support-functions definitions | ||||
\ Some control characters constants | \ Some control characters constants | ||||
▲ Show 20 Lines • Show All 1,368 Lines • Show Last 20 Lines |