Index: head/sys/boot/forth/beastie.4th =================================================================== --- head/sys/boot/forth/beastie.4th (revision 280936) +++ head/sys/boot/forth/beastie.4th (revision 280937) @@ -1,113 +1,115 @@ \ Copyright (c) 2003 Scott Long \ Copyright (c) 2003 Aleksander Fafula \ Copyright (c) 2006-2015 Devin Teske \ All rights reserved. \ \ Redistribution and use in source and binary forms, with or without \ modification, are permitted provided that the following conditions \ are met: \ 1. Redistributions of source code must retain the above copyright \ notice, this list of conditions and the following disclaimer. \ 2. Redistributions in binary form must reproduce the above copyright \ notice, this list of conditions and the following disclaimer in the \ documentation and/or other materials provided with the distribution. \ \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF \ SUCH DAMAGE. \ \ $FreeBSD$ marker task-beastie.4th -only forth definitions also support-functions +only forth definitions variable logoX variable logoY \ Initialize logo placement to defaults 46 logoX ! 4 logoY ! \ This function draws any number of beastie logos at (loader_logo_x, \ loader_logo_y) if defined, else (46,4) (to the right of the menu). To choose \ your beastie, set the variable `loader_logo' to the respective logo name. \ \ NOTE: Each is defined as a logo function in /boot/logo-${loader_logo}.4th \ NOTE: If `/boot/logo-${loader_logo}.4th' does not exist or does not define \ a `logo' function, no beastie is drawn. \ : draw-beastie ( -- ) \ at (loader_logo_x,loader_logo_y), else (46,4) s" loader_logo_x" getenv dup -1 <> if ?number 1 = if logoX ! then else drop then s" loader_logo_y" getenv dup -1 <> if ?number 1 = if logoY ! then else drop then \ If `logo' is defined, execute it s" logo" sfind ( -- xt|0 bool ) if logoX @ logoY @ rot execute else \ Not defined; try-include desired logo file drop ( xt = 0 ) \ cruft s" loader_logo" getenv dup -1 = over 0= or if dup 0= if 2drop else drop then \ getenv result unused loader_color? if s" try-include /boot/logo-orb.4th" else s" try-include /boot/logo-orbbw.4th" then else 2drop ( c-addr/u -- ) \ getenv result unused s" try-include /boot/logo-${loader_logo}.4th" then evaluate 1 spaces \ Execute `logo' if defined now s" logo" sfind if logoX @ logoY @ rot execute else drop then then ; +also support-functions + : beastie-start ( -- ) \ starts the menu s" console" getenv dup -1 <> if s" efi" 2swap contains? if s" set beastie_disable=YES" evaluate then else drop then s" beastie_disable" getenv dup -1 <> if s" YES" compare-insensitive 0= if any_conf_read? if load_xen_throw load_kernel load_modules then exit \ to autoboot (default) then else drop then s" loader_delay" getenv -1 = if s" include /boot/menu.rc" evaluate else drop ." Loading Menu (Ctrl-C to Abort)" cr s" set delay_command='include /boot/menu.rc'" evaluate s" set delay_showdots" evaluate delay_execute then ; -only forth also +only forth definitions Index: head/sys/boot/forth/check-password.4th =================================================================== --- head/sys/boot/forth/check-password.4th (revision 280936) +++ head/sys/boot/forth/check-password.4th (revision 280937) @@ -1,163 +1,170 @@ \ Copyright (c) 2006-2015 Devin Teske \ All rights reserved. \ \ Redistribution and use in source and binary forms, with or without \ modification, are permitted provided that the following conditions \ are met: \ 1. Redistributions of source code must retain the above copyright \ notice, this list of conditions and the following disclaimer. \ 2. Redistributions in binary form must reproduce the above copyright \ notice, this list of conditions and the following disclaimer in the \ documentation and/or other materials provided with the distribution. \ \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF \ SUCH DAMAGE. \ \ $FreeBSD$ marker task-check-password.4th include /boot/screen.4th +vocabulary password-processing +only forth also password-processing definitions + 13 constant enter_key \ The decimal ASCII value for Enter key 8 constant bs_key \ The decimal ASCII value for Backspace key 21 constant ctrl_u \ The decimal ASCII value for Ctrl-U sequence 255 constant readmax \ Maximum number of characters for the password variable read-tick \ Twiddle position (used by read) variable read-start \ Starting X offset (column)(used by read) create readval readmax allot \ input obtained (up to readmax characters) variable readlen \ input length \ This function blocks program flow (loops forever) until a key is pressed. \ The key that was pressed is added to the top of the stack in the form of its \ decimal ASCII representation. Note: the stack cannot be empty when this \ function starts or an underflow exception will occur. Simplest way to prevent \ this is to pass 0 as a stack parameter (ie. `0 sgetkey'). This function is \ called by the read function. You need not call it directly. NOTE: arrow keys \ show as 0 on the stack \ : sgetkey ( -- ) begin \ Loop forever key? if \ Was a key pressed? (see loader(8)) drop \ Remove stack-cruft key \ Get the key that was pressed \ Check key pressed (see loader(8)) and input limit dup 0<> if ( and ) readlen @ readmax < if \ Spin the twiddle and then exit this function read-tick @ dup 1+ 4 mod read-tick ! 2 spaces dup 0 = if ( 1 ) ." /" else dup 1 = if ( 2 ) ." -" else dup 2 = if ( 3 ) ." \" else dup 3 = if ( 4 ) ." |" else 1 spaces then then then then drop read-start @ 25 at-xy exit then then \ Always allow Backspace, Enter, and Ctrl-U dup bs_key = if exit then dup enter_key = if exit then dup ctrl_u = if exit then then 50 ms \ Sleep for 50 milliseconds (see loader(8)) again ; : cfill ( c c-addr/u -- ) begin dup 0> while -rot 2dup c! 1+ rot 1- repeat 2drop drop ; : read-reset ( -- ) 0 readlen ! 0 readval readmax cfill ; : read ( c-addr/u -- ) \ Expects string prompt as stack input 0 25 at-xy \ Move the cursor to the bottom-left dup 1+ read-start ! \ Store X offset after the prompt 0 readlen ! \ Initialize the read length type \ Print the prompt begin \ Loop forever 0 sgetkey \ Block here, waiting for a key to be pressed \ We are not going to echo the password to the screen (for \ security reasons). If Enter is pressed, we process the \ password, otherwise augment the key to a string. dup enter_key = if drop \ Clean up stack cruft 3 spaces \ Erase the twiddle 10 emit \ Echo new line exit else dup ctrl_u = if 3 spaces read-start @ 25 at-xy \ Erase the twiddle 0 readlen ! \ Reset input to NULL else dup bs_key = if readlen @ 1 - dup readlen ! \ Decrement input length dup 0< if drop 0 dup readlen ! then \ Don't go negative 0= if 3 spaces read-start @ 25 at-xy then \ Twiddle else dup \ Store the character \ NB: sgetkey prevents overflow by way of blocking \ at readmax except for Backspace or Enter readlen @ 1+ dup readlen ! 1- readval + c! then then then drop \ last key pressed again \ Enter was not pressed; repeat ; +only forth definitions also password-processing + : check-password ( -- ) \ Do not allow the user to proceed beyond this point if a boot-lock \ password has been set (preventing even boot from proceeding) s" bootlock_password" getenv dup -1 <> if dup readmax > if drop readmax then begin s" Boot Password: " read ( prompt -- ) 2dup readval readlen @ compare 0<> while 3000 ms ." loader: incorrect password" 10 emit repeat 2drop read-reset else drop then \ Exit if a password was not set s" password" getenv -1 = if exit else drop then \ We should prevent the user from visiting the menu or dropping to the \ interactive loader(8) prompt, but still allow the machine to boot... 0 autoboot \ Only reached if autoboot fails for any reason (including if/when \ the user aborts/escapes the countdown sequence leading to boot). s" password" getenv dup readmax > if drop readmax then begin s" Password: " read ( prompt -- ) 2dup readval readlen @ compare 0= if \ Correct password? 2drop read-reset exit then 3000 ms ." loader: incorrect password" 10 emit again ; + +only forth definitions Index: head/sys/boot/forth/delay.4th =================================================================== --- head/sys/boot/forth/delay.4th (revision 280936) +++ head/sys/boot/forth/delay.4th (revision 280937) @@ -1,112 +1,119 @@ -\ Copyright (c) 2008-2011 Devin Teske +\ Copyright (c) 2008-2015 Devin Teske \ All rights reserved. \ \ Redistribution and use in source and binary forms, with or without \ modification, are permitted provided that the following conditions \ are met: \ 1. Redistributions of source code must retain the above copyright \ notice, this list of conditions and the following disclaimer. \ 2. Redistributions in binary form must reproduce the above copyright \ notice, this list of conditions and the following disclaimer in the \ documentation and/or other materials provided with the distribution. \ \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF \ SUCH DAMAGE. \ \ $FreeBSD$ marker task-delay.4th +vocabulary delay-processing +only forth also delay-processing definitions + 2 constant delay_default \ Default delay (in seconds) 3 constant etx_key \ End-of-Text character produced by Ctrl+C 13 constant enter_key \ Carriage-Return character produce by ENTER 27 constant esc_key \ Escape character produced by ESC or Ctrl+[ variable delay_tstart \ state variable used for delay timing variable delay_delay \ determined configurable delay duration variable delay_cancelled \ state variable for user cancellation variable delay_showdots \ whether continually print dots while waiting +only forth definitions also delay-processing + : delay_execute ( -- ) \ make sure that we have a command to execute s" delay_command" getenv dup -1 = if drop exit then \ read custom time-duration (if set) s" loader_delay" getenv dup -1 = if drop \ no custom duration (remove dup'd bunk -1) delay_default \ use default setting (replacing bunk -1) else \ make sure custom duration is a number ?number 0= if delay_default \ use default if otherwise then then \ initialize state variables delay_delay ! \ stored value is on the stack from above seconds delay_tstart ! \ store the time we started 0 delay_cancelled ! \ boolean flag indicating user-cancelled event false delay_showdots ! \ reset to zero and read from environment s" delay_showdots" getenv dup -1 <> if 2drop \ don't need the value, just existance true delay_showdots ! else drop then \ Loop until we have exceeded the desired time duration begin 25 ms \ sleep for 25 milliseconds (40 iterations/sec) \ throw some dots up on the screen if desired delay_showdots @ if ." ." \ dots visually aid in the perception of time then \ was a key depressed? key? if key \ obtain ASCII value for keystroke dup enter_key = if -1 delay_delay ! \ break loop then dup etx_key = swap esc_key = OR if -1 delay_delay ! \ break loop -1 delay_cancelled ! \ set cancelled flag then then \ if the time duration is set to zero, loop forever \ waiting for either ENTER or Ctrl-C/Escape to be pressed delay_delay @ 0> if \ calculate elapsed time seconds delay_tstart @ - delay_delay @ > else -1 \ break loop then until \ if we were throwing up dots, throw up a line-break delay_showdots @ if cr then \ did the user press either Ctrl-C or Escape? delay_cancelled @ if 2drop \ we don't need the command string anymore else evaluate \ evaluate/execute the command string then ; + +only forth definitions Index: head/sys/boot/forth/frames.4th =================================================================== --- head/sys/boot/forth/frames.4th (revision 280936) +++ head/sys/boot/forth/frames.4th (revision 280937) @@ -1,158 +1,165 @@ \ Copyright (c) 2003 Scott Long \ Copyright (c) 2012-2015 Devin Teske \ All rights reserved. \ \ Redistribution and use in source and binary forms, with or without \ modification, are permitted provided that the following conditions \ are met: \ 1. Redistributions of source code must retain the above copyright \ notice, this list of conditions and the following disclaimer. \ 2. Redistributions in binary form must reproduce the above copyright \ notice, this list of conditions and the following disclaimer in the \ documentation and/or other materials provided with the distribution. \ \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF \ SUCH DAMAGE. \ \ $FreeBSD$ marker task-frames.4th +vocabulary frame-drawing +only forth also frame-drawing definitions + \ XXX Filled boxes are left as an exercise for the reader... ;-/ variable h_el variable v_el variable lt_el variable lb_el variable rt_el variable rb_el variable fill \ ASCII frames (used when serial console is detected) 45 constant ascii_dash 61 constant ascii_equal 124 constant ascii_pipe 43 constant ascii_plus s" arch-pc98" environment? [if] \ Single frames 149 constant sh_el 150 constant sv_el 152 constant slt_el 154 constant slb_el 153 constant srt_el 155 constant srb_el \ Double frames 149 constant dh_el 150 constant dv_el 152 constant dlt_el 154 constant dlb_el 153 constant drt_el 155 constant drb_el \ Fillings 0 constant fill_none 32 constant fill_blank 135 constant fill_dark 135 constant fill_med 135 constant fill_bright [else] \ Single frames 196 constant sh_el 179 constant sv_el 218 constant slt_el 192 constant slb_el 191 constant srt_el 217 constant srb_el \ Double frames 205 constant dh_el 186 constant dv_el 201 constant dlt_el 200 constant dlb_el 187 constant drt_el 188 constant drb_el \ Fillings 0 constant fill_none 32 constant fill_blank 176 constant fill_dark 177 constant fill_med 178 constant fill_bright [then] +only forth definitions also frame-drawing + : hline ( len x y -- ) \ Draw horizontal single line at-xy \ move cursor 0 do h_el @ emit loop ; : f_ascii ( -- ) ( -- ) \ set frames to ascii ascii_dash h_el ! ascii_pipe v_el ! ascii_plus lt_el ! ascii_plus lb_el ! ascii_plus rt_el ! ascii_plus rb_el ! ; : f_single ( -- ) \ set frames to single boot_serial? if f_ascii exit then sh_el h_el ! sv_el v_el ! slt_el lt_el ! slb_el lb_el ! srt_el rt_el ! srb_el rb_el ! ; : f_double ( -- ) \ set frames to double boot_serial? if f_ascii ascii_equal h_el ! exit then dh_el h_el ! dv_el v_el ! dlt_el lt_el ! dlb_el lb_el ! drt_el rt_el ! drb_el rb_el ! ; : vline ( len x y -- ) \ Draw vertical single line 2dup 4 pick 0 do at-xy v_el @ emit 1+ 2dup loop 2drop 2drop drop ; : box ( w h x y -- ) \ Draw a box 2dup 1+ 4 pick 1- -rot vline \ Draw left vert line 2dup 1+ swap 5 pick + swap 4 pick 1- -rot vline \ Draw right vert line 2dup swap 1+ swap 5 pick 1- -rot hline \ Draw top horiz line 2dup swap 1+ swap 4 pick + 5 pick 1- -rot hline \ Draw bottom horiz line 2dup at-xy lt_el @ emit \ Draw left-top corner 2dup 4 pick + at-xy lb_el @ emit \ Draw left bottom corner 2dup swap 5 pick + swap at-xy rt_el @ emit \ Draw right top corner 2 pick + swap 3 pick + swap at-xy rb_el @ emit 2drop ; f_single fill_none fill ! + +only forth definitions Index: head/sys/boot/forth/loader.4th =================================================================== --- head/sys/boot/forth/loader.4th (revision 280936) +++ head/sys/boot/forth/loader.4th (revision 280937) @@ -1,249 +1,252 @@ \ Copyright (c) 1999 Daniel C. Sobral \ Copyright (c) 2011-2015 Devin Teske \ All rights reserved. \ \ Redistribution and use in source and binary forms, with or without \ modification, are permitted provided that the following conditions \ are met: \ 1. Redistributions of source code must retain the above copyright \ notice, this list of conditions and the following disclaimer. \ 2. Redistributions in binary form must reproduce the above copyright \ notice, this list of conditions and the following disclaimer in the \ documentation and/or other materials provided with the distribution. \ \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF \ SUCH DAMAGE. \ \ $FreeBSD$ +only forth definitions + s" arch-i386" environment? [if] [if] s" loader_version" environment? [if] 11 < [if] .( Loader version 1.1+ required) cr abort [then] [else] .( Could not get loader version!) cr abort [then] [then] [then] 256 dictthreshold ! \ 256 cells minimum free space 2048 dictincrease ! \ 2048 additional cells each time include /boot/support.4th include /boot/color.4th include /boot/delay.4th include /boot/check-password.4th -only forth also support-functions also builtins definitions +only forth definitions : bootmsg ( -- ) loader_color? dup ( -- bool bool ) if 7 fg 4 bg then ." Booting..." if me then cr ; : try-menu-unset \ menu-unset may not be present s" beastie_disable" getenv dup -1 <> if s" YES" compare-insensitive 0= if exit then else drop then s" menu-unset" sfind if execute else drop then s" menusets-unset" sfind if execute else drop then ; +only forth also support-functions also builtins definitions + : boot 0= if ( interpreted ) get_arguments then \ Unload only if a path was passed dup if >r over r> swap c@ [char] - <> if 0 1 unload drop else s" kernelname" getenv? if ( a kernel has been loaded ) try-menu-unset bootmsg 1 boot exit then load_kernel_and_modules ?dup if exit then try-menu-unset bootmsg 0 1 boot exit then else s" kernelname" getenv? if ( a kernel has been loaded ) try-menu-unset bootmsg 1 boot exit then load_kernel_and_modules ?dup if exit then try-menu-unset bootmsg 0 1 boot exit then load_kernel_and_modules ?dup 0= if bootmsg 0 1 boot then ; \ ***** boot-conf \ \ Prepares to boot as specified by loaded configuration files. : boot-conf 0= if ( interpreted ) get_arguments then 0 1 unload drop load_kernel_and_modules ?dup 0= if 0 1 autoboot then ; -also forth definitions also builtins +also forth definitions previous builtin: boot builtin: boot-conf only forth definitions also support-functions \ ***** start \ \ Initializes support.4th global variables, sets loader_conf_files, \ processes conf files, and, if any one such file was succesfully \ read to the end, loads kernel and modules. : start ( -- ) ( throws: abort & user-defined ) s" /boot/defaults/loader.conf" initialize include_conf_files include_nextboot_file \ Will *NOT* try to load kernel and modules if no configuration file \ was succesfully loaded! any_conf_read? if s" loader_delay" getenv -1 = if load_xen_throw load_kernel load_modules else drop ." Loading Kernel and Modules (Ctrl-C to Abort)" cr s" also support-functions" evaluate s" set delay_command='load_xen_throw load_kernel load_modules'" evaluate s" set delay_showdots" evaluate delay_execute then then ; \ ***** initialize \ \ Overrides support.4th initialization word with one that does \ everything start one does, short of loading the kernel and \ modules. Returns a flag : initialize ( -- flag ) s" /boot/defaults/loader.conf" initialize include_conf_files include_nextboot_file any_conf_read? ; \ ***** read-conf \ \ Read a configuration file, whose name was specified on the command \ line, if interpreted, or given on the stack, if compiled in. : (read-conf) ( addr len -- ) conf_files string= include_conf_files \ Will recurse on new loader_conf_files definitions ; : read-conf ( | addr len -- ) ( throws: abort & user-defined ) state @ if \ Compiling postpone (read-conf) else \ Interpreting bl parse (read-conf) then ; immediate \ show, enable, disable, toggle module loading. They all take module from \ the next word : set-module-flag ( module_addr val -- ) \ set and print flag over module.flag ! dup module.name strtype module.flag @ if ." will be loaded" else ." will not be loaded" then cr ; : enable-module find-module ?dup if true set-module-flag then ; : disable-module find-module ?dup if false set-module-flag then ; : toggle-module find-module ?dup if dup module.flag @ 0= set-module-flag then ; \ ***** show-module \ \ Show loading information about a module. : show-module ( -- ) find-module ?dup if show-one-module then ; \ Words to be used inside configuration files : retry false ; \ For use in load error commands : ignore true ; \ For use in load error commands \ Return to strict forth vocabulary : #type over - >r type r> spaces ; : .? 2 spaces 2swap 15 #type 2 spaces type cr ; : ? ['] ? execute s" boot-conf" s" load kernel and modules, then autoboot" .? s" read-conf" s" read a configuration file" .? s" enable-module" s" enable loading of a module" .? s" disable-module" s" disable loading of a module" .? s" toggle-module" s" toggle loading of a module" .? s" show-module" s" show module load data" .? s" try-include" s" try to load/interpret files" .? ; : try-include ( -- ) \ see loader.4th(8) ['] include ( -- xt ) \ get the execution token of `include' catch ( xt -- exception# | 0 ) if \ failed LF parse ( c -- s-addr/u ) 2drop \ advance >in to EOL (drop data) \ ... prevents words unused by `include' from being interpreted then ; immediate \ interpret immediately for access to `source' (aka tib) -only forth also - +only forth definitions Index: head/sys/boot/forth/menu-commands.4th =================================================================== --- head/sys/boot/forth/menu-commands.4th (revision 280936) +++ head/sys/boot/forth/menu-commands.4th (revision 280937) @@ -1,348 +1,354 @@ -\ Copyright (c) 2006-2013 Devin Teske +\ Copyright (c) 2006-2015 Devin Teske \ All rights reserved. \ \ Redistribution and use in source and binary forms, with or without \ modification, are permitted provided that the following conditions \ are met: \ 1. Redistributions of source code must retain the above copyright \ notice, this list of conditions and the following disclaimer. \ 2. Redistributions in binary form must reproduce the above copyright \ notice, this list of conditions and the following disclaimer in the \ documentation and/or other materials provided with the distribution. \ \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF \ SUCH DAMAGE. \ \ $FreeBSD$ marker task-menu-commands.4th include /boot/menusets.4th +only forth definitions + variable kernel_state variable root_state 0 kernel_state ! 0 root_state ! +also menu-namespace also menu-command-helpers + \ \ Boot \ : init_boot ( N -- N ) dup s" boot_single" getenv -1 <> if drop ( n n c-addr -- n n ) \ unused toggle_menuitem ( n n -- n n ) s" set menu_keycode[N]=115" \ base command to execute else s" set menu_keycode[N]=98" \ base command to execute then 17 +c! \ replace 'N' with ASCII numeral evaluate ; \ \ Alternate Boot \ : init_altboot ( N -- N ) dup s" boot_single" getenv -1 <> if drop ( n c-addr -- n ) \ unused toggle_menuitem ( n -- n ) s" set menu_keycode[N]=109" \ base command to execute else s" set menu_keycode[N]=115" \ base command to execute then 17 +c! \ replace 'N' with ASCII numeral evaluate ; : altboot ( N -- NOTREACHED ) s" boot_single" 2dup getenv -1 <> if drop ( c-addr/u c-addr -- c-addr/u ) \ unused unsetenv ( c-addr/u -- ) else 2drop ( c-addr/u -- ) \ unused s" set boot_single=YES" evaluate then 0 boot ( state -- ) ; \ \ ACPI \ : acpi_enable ( -- ) s" set acpi_load=YES" evaluate \ XXX deprecated but harmless s" set hint.acpi.0.disabled=0" evaluate s" loader.acpi_disabled_by_user" unsetenv ; : acpi_disable ( -- ) s" acpi_load" unsetenv \ XXX deprecated but harmless s" set hint.acpi.0.disabled=1" evaluate s" set loader.acpi_disabled_by_user=1" evaluate ; : toggle_acpi ( N -- N TRUE ) \ Make changes effective _before_ calling menu-redraw acpienabled? if acpi_disable else acpi_enable then menu-redraw TRUE \ loop menu again ; \ \ Safe Mode \ : safemode_enabled? ( -- flag ) s" kern.smp.disabled" getenv -1 <> dup if swap drop ( c-addr flag -- flag ) then ; : safemode_enable ( -- ) s" set kern.smp.disabled=1" evaluate s" set hw.ata.ata_dma=0" evaluate s" set hw.ata.atapi_dma=0" evaluate s" set hw.ata.wc=0" evaluate s" set hw.eisa_slots=0" evaluate s" set kern.eventtimer.periodic=1" evaluate s" set kern.geom.part.check_integrity=0" evaluate ; : safemode_disable ( -- ) s" kern.smp.disabled" unsetenv s" hw.ata.ata_dma" unsetenv s" hw.ata.atapi_dma" unsetenv s" hw.ata.wc" unsetenv s" hw.eisa_slots" unsetenv s" kern.eventtimer.periodic" unsetenv s" kern.geom.part.check_integrity" unsetenv ; : init_safemode ( N -- N ) safemode_enabled? if toggle_menuitem ( n -- n ) then ; : toggle_safemode ( N -- N TRUE ) toggle_menuitem \ Now we're going to make the change effective dup toggle_stateN @ 0= if safemode_disable else safemode_enable then menu-redraw TRUE \ loop menu again ; \ \ Single User Mode \ : singleuser_enabled? ( -- flag ) s" boot_single" getenv -1 <> dup if swap drop ( c-addr flag -- flag ) then ; : singleuser_enable ( -- ) s" set boot_single=YES" evaluate ; : singleuser_disable ( -- ) s" boot_single" unsetenv ; : init_singleuser ( N -- N ) singleuser_enabled? if toggle_menuitem ( n -- n ) then ; : toggle_singleuser ( N -- N TRUE ) toggle_menuitem menu-redraw \ Now we're going to make the change effective dup toggle_stateN @ 0= if singleuser_disable else singleuser_enable then TRUE \ loop menu again ; \ \ Verbose Boot \ : verbose_enabled? ( -- flag ) s" boot_verbose" getenv -1 <> dup if swap drop ( c-addr flag -- flag ) then ; : verbose_enable ( -- ) s" set boot_verbose=YES" evaluate ; : verbose_disable ( -- ) s" boot_verbose" unsetenv ; : init_verbose ( N -- N ) verbose_enabled? if toggle_menuitem ( n -- n ) then ; : toggle_verbose ( N -- N TRUE ) toggle_menuitem menu-redraw \ Now we're going to make the change effective dup toggle_stateN @ 0= if verbose_disable else verbose_enable then TRUE \ loop menu again ; \ \ Escape to Prompt \ : goto_prompt ( N -- N FALSE ) s" set autoboot_delay=NO" evaluate cr ." To get back to the menu, type `menu' and press ENTER" cr ." or type `boot' and press ENTER to start FreeBSD." cr cr FALSE \ exit the menu ; \ \ Cyclestate (used by kernel/root below) \ : init_cyclestate ( N K -- N ) over cycle_stateN ( n k -- n k addr ) begin tuck @ ( n k addr -- n addr k c ) over <> ( n addr k c -- n addr k 0|-1 ) while rot ( n addr k -- addr k n ) cycle_menuitem swap rot ( addr k n -- n k addr ) repeat 2drop ( n k addr -- n ) ; \ \ Kernel \ : init_kernel ( N -- N ) kernel_state @ ( n -- n k ) init_cyclestate ( n k -- n ) ; : activate_kernel ( N -- N ) dup cycle_stateN @ ( n -- n n2 ) dup kernel_state ! ( n n2 -- n n2 ) \ copy for re-initialization 48 + ( n n2 -- n n2' ) \ kernel_state to ASCII num s" set kernel=${kernel_prefix}${kernel[N]}${kernel_suffix}" 36 +c! ( n n2 c-addr/u -- n c-addr/u ) \ 'N' to ASCII num evaluate ( n c-addr/u -- n ) \ sets $kernel to full kernel-path ; : cycle_kernel ( N -- N TRUE ) cycle_menuitem \ cycle cycle_stateN to next value activate_kernel \ apply current cycle_stateN menu-redraw \ redraw menu TRUE \ loop menu again ; \ \ Root \ : init_root ( N -- N ) root_state @ ( n -- n k ) init_cyclestate ( n k -- n ) ; : activate_root ( N -- N ) dup cycle_stateN @ ( n -- n n2 ) dup root_state ! ( n n2 -- n n2 ) \ copy for re-initialization 48 + ( n n2 -- n n2' ) \ root_state to ASCII num s" set root=${root_prefix}${root[N]}${root_suffix}" 30 +c! ( n n2 c-addr/u -- n c-addr/u ) \ 'N' to ASCII num evaluate ( n c-addr/u -- n ) \ sets $root to full kernel-path ; : cycle_root ( N -- N TRUE ) cycle_menuitem \ cycle cycle_stateN to next value activate_root \ apply current cycle_stateN menu-redraw \ redraw menu TRUE \ loop menu again ; \ \ Menusets \ : goto_menu ( N M -- N TRUE ) menu-unset menuset-loadsetnum ( n m -- n ) menu-redraw TRUE \ Loop menu again ; \ \ Defaults \ : set_default_boot_options ( N -- N TRUE ) acpi_enable safemode_disable singleuser_disable verbose_disable 2 goto_menu ; + +only forth definitions Index: head/sys/boot/forth/menu.4th =================================================================== --- head/sys/boot/forth/menu.4th (revision 280936) +++ head/sys/boot/forth/menu.4th (revision 280937) @@ -1,1287 +1,1319 @@ \ Copyright (c) 2003 Scott Long \ Copyright (c) 2003 Aleksander Fafula \ Copyright (c) 2006-2015 Devin Teske \ All rights reserved. \ \ Redistribution and use in source and binary forms, with or without \ modification, are permitted provided that the following conditions \ are met: \ 1. Redistributions of source code must retain the above copyright \ notice, this list of conditions and the following disclaimer. \ 2. Redistributions in binary form must reproduce the above copyright \ notice, this list of conditions and the following disclaimer in the \ documentation and/or other materials provided with the distribution. \ \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF \ SUCH DAMAGE. \ \ $FreeBSD$ marker task-menu.4th \ Frame drawing include /boot/frames.4th +vocabulary menu-infrastructure +vocabulary menu-namespace +vocabulary menu-command-helpers + +only forth also menu-infrastructure definitions + f_double \ Set frames to double (see frames.4th). Replace with \ f_single if you want single frames. 46 constant dot \ ASCII definition of a period (in decimal) 5 constant menu_default_x \ default column position of timeout 10 constant menu_default_y \ default row position of timeout msg 4 constant menu_timeout_default_x \ default column position of timeout 23 constant menu_timeout_default_y \ default row position of timeout msg 10 constant menu_timeout_default \ default timeout (in seconds) \ Customize the following values with care 1 constant menu_start \ Numerical prefix of first menu item dot constant bullet \ Menu bullet (appears after numerical prefix) 5 constant menu_x \ Row position of the menu (from the top) 10 constant menu_y \ Column position of the menu (from left side) \ Menu Appearance variable menuidx \ Menu item stack for number prefixes variable menurow \ Menu item stack for positioning variable menubllt \ Menu item bullet \ Menu Positioning variable menuX \ Menu X offset (columns) variable menuY \ Menu Y offset (rows) \ Menu-item elements -variable menukey1 -variable menukey2 -variable menukey3 -variable menukey4 -variable menukey5 -variable menukey6 -variable menukey7 -variable menukey8 -variable menureboot variable menurebootadded -variable menuacpi -variable menuoptions -variable menukernel \ Parsing of kernels into menu-items variable kernidx variable kernlen variable kernmenuidx \ Menu timer [count-down] variables variable menu_timeout_enabled \ timeout state (internal use only) variable menu_time \ variable for tracking the passage of time variable menu_timeout \ determined configurable delay duration variable menu_timeout_x \ column position of timeout message variable menu_timeout_y \ row position of timeout message +\ Containers for parsing kernels into menu-items +create kerncapbuf 64 allot +create kerndefault 64 allot +create kernelsbuf 256 allot + +only forth also menu-namespace definitions + +\ Menu-item key association/detection +variable menukey1 +variable menukey2 +variable menukey3 +variable menukey4 +variable menukey5 +variable menukey6 +variable menukey7 +variable menukey8 +variable menureboot +variable menuacpi +variable menuoptions +variable menukernel + \ Menu initialization status variables variable init_state1 variable init_state2 variable init_state3 variable init_state4 variable init_state5 variable init_state6 variable init_state7 variable init_state8 \ Boolean option status variables variable toggle_state1 variable toggle_state2 variable toggle_state3 variable toggle_state4 variable toggle_state5 variable toggle_state6 variable toggle_state7 variable toggle_state8 \ Array option status variables variable cycle_state1 variable cycle_state2 variable cycle_state3 variable cycle_state4 variable cycle_state5 variable cycle_state6 variable cycle_state7 variable cycle_state8 \ Containers for storing the initial caption text create init_text1 64 allot create init_text2 64 allot create init_text3 64 allot create init_text4 64 allot create init_text5 64 allot create init_text6 64 allot create init_text7 64 allot create init_text8 64 allot -\ Containers for parsing kernels into menu-items -create kerncapbuf 64 allot -create kerndefault 64 allot -create kernelsbuf 256 allot +only forth definitions +: arch-i386? ( -- BOOL ) \ Returns TRUE (-1) on i386, FALSE (0) otherwise. + s" arch-i386" environment? dup if + drop + then +; + +: acpipresent? ( -- flag ) \ Returns TRUE if ACPI is present, FALSE otherwise + s" hint.acpi.0.rsdp" getenv + dup -1 = if + drop false exit + then + 2drop + true +; + +: acpienabled? ( -- flag ) \ Returns TRUE if ACPI is enabled, FALSE otherwise + s" hint.acpi.0.disabled" getenv + dup -1 <> if + s" 0" compare 0<> if + false exit + then + else + drop + then + true +; + : +c! ( N C-ADDR/U K -- C-ADDR/U ) 3 pick 3 pick ( n c-addr/u k -- n c-addr/u k n c-addr ) rot + c! ( n c-addr/u k n c-addr -- n c-addr/u ) rot drop ( n c-addr/u -- c-addr/u ) ; -: delim? ( C -- BOOL ) - dup 32 = ( c -- c bool ) \ [sp] space - over 9 = or ( c bool -- c bool ) \ [ht] horizontal tab - over 10 = or ( c bool -- c bool ) \ [nl] newline - over 13 = or ( c bool -- c bool ) \ [cr] carriage return - over [char] , = or ( c bool -- c bool ) \ comma - swap drop ( c bool -- bool ) \ return boolean -; +only forth also menu-namespace definitions \ Forth variables -: menukeyN ( N -- ADDR ) s" menukeyN" 7 +c! evaluate ; -: init_stateN ( N -- ADDR ) s" init_stateN" 10 +c! evaluate ; -: toggle_stateN ( N -- ADDR ) s" toggle_stateN" 12 +c! evaluate ; -: cycle_stateN ( N -- ADDR ) s" cycle_stateN" 11 +c! evaluate ; -: init_textN ( N -- C-ADDR ) s" init_textN" 9 +c! evaluate ; +: namespace ( C-ADDR/U N -- ) also menu-namespace +c! evaluate previous ; +: menukeyN ( N -- ADDR ) s" menukeyN" 7 namespace ; +: init_stateN ( N -- ADDR ) s" init_stateN" 10 namespace ; +: toggle_stateN ( N -- ADDR ) s" toggle_stateN" 12 namespace ; +: cycle_stateN ( N -- ADDR ) s" cycle_stateN" 11 namespace ; +: init_textN ( N -- C-ADDR ) s" init_textN" 9 namespace ; \ Environment variables : kernel[x] ( N -- C-ADDR/U ) s" kernel[x]" 7 +c! ; : menu_init[x] ( N -- C-ADDR/U ) s" menu_init[x]" 10 +c! ; : menu_command[x] ( N -- C-ADDR/U ) s" menu_command[x]" 13 +c! ; : menu_caption[x] ( N -- C-ADDR/U ) s" menu_caption[x]" 13 +c! ; : ansi_caption[x] ( N -- C-ADDR/U ) s" ansi_caption[x]" 13 +c! ; : menu_keycode[x] ( N -- C-ADDR/U ) s" menu_keycode[x]" 13 +c! ; : toggled_text[x] ( N -- C-ADDR/U ) s" toggled_text[x]" 13 +c! ; : toggled_ansi[x] ( N -- C-ADDR/U ) s" toggled_ansi[x]" 13 +c! ; : menu_caption[x][y] ( N M -- C-ADDR/U ) s" menu_caption[x][y]" 16 +c! 13 +c! ; : ansi_caption[x][y] ( N M -- C-ADDR/U ) s" ansi_caption[x][y]" 16 +c! 13 +c! ; -: arch-i386? ( -- BOOL ) \ Returns TRUE (-1) on i386, FALSE (0) otherwise. - s" arch-i386" environment? dup if - drop - then -; +also menu-infrastructure definitions \ This function prints a menu item at menuX (row) and menuY (column), returns \ the incremental decimal ASCII value associated with the menu item, and \ increments the cursor position to the next row for the creation of the next \ menu item. This function is called by the menu-create function. You need not \ call it directly. \ : printmenuitem ( menu_item_str -- ascii_keycode ) menurow dup @ 1+ swap ! ( increment menurow ) menuidx dup @ 1+ swap ! ( increment menuidx ) \ Calculate the menuitem row position menurow @ menuY @ + \ Position the cursor at the menuitem position dup menuX @ swap at-xy \ Print the value of menuidx loader_color? if ." " (  ) then menuidx @ . loader_color? if ." " (  ) then \ Move the cursor forward 1 column dup menuX @ 1+ swap at-xy menubllt @ emit \ Print the menu bullet using the emit function \ Move the cursor to the 3rd column from the current position \ to allow for a space between the numerical prefix and the \ text caption menuX @ 3 + swap at-xy \ Print the menu caption (we expect a string to be on the stack \ prior to invoking this function) type \ Here we will add the ASCII decimal of the numerical prefix \ to the stack (decimal ASCII for `1' is 49) as a "return value" menuidx @ 48 + ; -: toggle_menuitem ( N -- N ) \ toggles caption text and internal menuitem state - - \ ASCII numeral equal to user-selected menu item must be on the stack. - \ We do not modify the stack, so the ASCII numeral is left on top. - - dup init_textN c@ 0= if - \ NOTE: no need to check toggle_stateN since the first time we - \ are called, we will populate init_textN. Further, we don't - \ need to test whether menu_caption[x] (ansi_caption[x] when - \ loader_color?=1) is available since we would not have been - \ called if the caption was NULL. - - \ base name of environment variable - dup ( n -- n n ) \ key pressed - loader_color? if - ansi_caption[x] - else - menu_caption[x] - then - getenv dup -1 <> if - - 2 pick ( n c-addr/u -- n c-addr/u n ) - init_textN ( n c-addr/u n -- n c-addr/u c-addr ) - - \ now we have the buffer c-addr on top - \ ( followed by c-addr/u of current caption ) - - \ Copy the current caption into our buffer - 2dup c! -rot \ store strlen at first byte - begin - rot 1+ \ bring alt addr to top and increment - -rot -rot \ bring buffer addr to top - 2dup c@ swap c! \ copy current character - 1+ \ increment buffer addr - rot 1- \ bring buffer len to top and decrement - dup 0= \ exit loop if buffer len is zero - until - 2drop \ buffer len/addr - drop \ alt addr - - else - drop - then - then - - \ Now we are certain to have init_textN populated with the initial - \ value of menu_caption[x] (ansi_caption[x] with loader_color enabled). - \ We can now use init_textN as the untoggled caption and - \ toggled_text[x] (toggled_ansi[x] with loader_color enabled) as the - \ toggled caption and store the appropriate value into menu_caption[x] - \ (again, ansi_caption[x] with loader_color enabled). Last, we'll - \ negate the toggled state so that we reverse the flow on subsequent - \ calls. - - dup toggle_stateN @ 0= if - \ state is OFF, toggle to ON - - dup ( n -- n n ) \ key pressed - loader_color? if - toggled_ansi[x] - else - toggled_text[x] - then - getenv dup -1 <> if - \ Assign toggled text to menu caption - 2 pick ( n c-addr/u -- n c-addr/u n ) \ key pressed - loader_color? if - ansi_caption[x] - else - menu_caption[x] - then - setenv - else - \ No toggled text, keep the same caption - drop ( n -1 -- n ) \ getenv cruft - then - - true \ new value of toggle state var (to be stored later) - else - \ state is ON, toggle to OFF - - dup init_textN count ( n -- n c-addr/u ) - - \ Assign init_textN text to menu caption - 2 pick ( n c-addr/u -- n c-addr/u n ) \ key pressed - loader_color? if - ansi_caption[x] - else - menu_caption[x] - then - setenv - - false \ new value of toggle state var (to be stored below) - then - - \ now we'll store the new toggle state (on top of stack) - over toggle_stateN ! -; - -: cycle_menuitem ( N -- N ) \ cycles through array of choices for a menuitem - - \ ASCII numeral equal to user-selected menu item must be on the stack. - \ We do not modify the stack, so the ASCII numeral is left on top. - - dup cycle_stateN dup @ 1+ \ get value and increment - - \ Before assigning the (incremented) value back to the pointer, - \ let's test for the existence of this particular array element. - \ If the element exists, we'll store index value and move on. - \ Otherwise, we'll loop around to zero and store that. - - dup 48 + ( n addr k -- n addr k k' ) - \ duplicate array index and convert to ASCII numeral - - 3 pick swap ( n addr k k' -- n addr k n k' ) \ (n,k') as (x,y) - loader_color? if - ansi_caption[x][y] - else - menu_caption[x][y] - then - ( n addr k n k' -- n addr k c-addr/u ) - - \ Now test for the existence of our incremented array index in the - \ form of $menu_caption[x][y] ($ansi_caption[x][y] with loader_color - \ enabled) as set in loader.rc(5), et. al. - - getenv dup -1 = if - \ No caption set for this array index. Loop back to zero. - - drop ( n addr k -1 -- n addr k ) \ getenv cruft - drop 0 ( n addr k -- n addr 0 ) \ new value to store later - - 2 pick [char] 0 ( n addr 0 -- n addr 0 n 48 ) \ (n,48) as (x,y) - loader_color? if - ansi_caption[x][y] - else - menu_caption[x][y] - then - ( n addr 0 n 48 -- n addr 0 c-addr/u ) - getenv dup -1 = if - \ Highly unlikely to occur, but to ensure things move - \ along smoothly, allocate a temporary NULL string - drop ( cruft ) s" " - then - then - - \ At this point, we should have the following on the stack (in order, - \ from bottom to top): - \ - \ n - Ascii numeral representing the menu choice (inherited) - \ addr - address of our internal cycle_stateN variable - \ k - zero-based number we intend to store to the above - \ c-addr/u - string value we intend to store to menu_caption[x] - \ (or ansi_caption[x] with loader_color enabled) - \ - \ Let's perform what we need to with the above. - - \ Assign array value text to menu caption - 4 pick ( n addr k c-addr/u -- n addr k c-addr/u n ) - loader_color? if - ansi_caption[x] - else - menu_caption[x] - then - setenv - - swap ! ( n addr k -- n ) \ update array state variable -; - -: acpipresent? ( -- flag ) \ Returns TRUE if ACPI is present, FALSE otherwise - s" hint.acpi.0.rsdp" getenv - dup -1 = if - drop false exit - then - 2drop - true -; - -: acpienabled? ( -- flag ) \ Returns TRUE if ACPI is enabled, FALSE otherwise - s" hint.acpi.0.disabled" getenv - dup -1 <> if - s" 0" compare 0<> if - false exit - then - else - drop - then - true -; - \ This function prints the appropriate menuitem basename to the stack if an \ ACPI option is to be presented to the user, otherwise returns -1. Used \ internally by menu-create, you need not (nor should you) call this directly. \ : acpimenuitem ( -- C-Addr/U | -1 ) arch-i386? if acpipresent? if acpienabled? if loader_color? if s" toggled_ansi[x]" else s" toggled_text[x]" then else loader_color? if s" ansi_caption[x]" else s" menu_caption[x]" then then else menuidx dup @ 1+ swap ! ( increment menuidx ) -1 then else -1 then ; +: delim? ( C -- BOOL ) + dup 32 = ( c -- c bool ) \ [sp] space + over 9 = or ( c bool -- c bool ) \ [ht] horizontal tab + over 10 = or ( c bool -- c bool ) \ [nl] newline + over 13 = or ( c bool -- c bool ) \ [cr] carriage return + over [char] , = or ( c bool -- c bool ) \ comma + swap drop ( c bool -- bool ) \ return boolean +; + \ This function parses $kernels into variables that are used by the menu to \ display wich kernel to boot when the [overloaded] `boot' word is interpreted. \ Used internally by menu-create, you need not (nor should you) call this \ directly. \ : parse-kernels ( N -- ) \ kernidx kernidx ! ( n -- ) \ store provided `x' value [char] 0 kernmenuidx ! \ initialize `y' value for menu_caption[x][y] \ Attempt to get a list of kernels, fall back to sensible default s" kernels" getenv dup -1 = if drop ( cruft ) s" kernel kernel.old" then ( -- c-addr/u ) \ Check to see if the user has altered $kernel by comparing it against \ $kernel[N] where N is kernel_state (the actively displayed kernel). s" kernel_state" evaluate @ 48 + s" kernel[N]" 7 +c! getenv dup -1 <> if s" kernel" getenv dup -1 = if drop ( cruft ) s" " then 2swap 2over compare 0= if 2drop FALSE ( skip below conditional ) else \ User has changed $kernel TRUE ( slurp in new value ) then else \ We haven't yet parsed $kernels into $kernel[N] drop ( getenv cruft ) s" kernel" getenv dup -1 = if drop ( cruft ) s" " then TRUE ( slurp in initial value ) then ( c-addr/u -- c-addr/u c-addr/u,-1 | 0 ) if \ slurp new value into kerndefault kerndefault 1+ 0 2swap strcat swap 1- c! then \ Clear out existing parsed-kernels kernidx @ [char] 0 begin dup kernel[x] unsetenv 2dup menu_caption[x][y] unsetenv 2dup ansi_caption[x][y] unsetenv 1+ dup [char] 8 > until 2drop \ Step through the string until we find the end begin 0 kernlen ! \ initialize length of value \ Skip leading whitespace and/or comma delimiters begin dup 0<> if over c@ delim? ( c-addr/u -- c-addr/u bool ) else false ( c-addr/u -- c-addr/u bool ) then while 1- swap 1+ swap ( c-addr/u -- c-addr'/u' ) repeat ( c-addr/u -- c-addr'/u' ) dup 0= if \ end of string while eating whitespace 2drop ( c-addr/u -- ) kernmenuidx @ [char] 0 <> if \ found at least one exit \ all done then \ No entries in $kernels; use $kernel instead s" kernel" getenv dup -1 = if drop ( cruft ) s" " then ( -- c-addr/u ) dup kernlen ! \ store entire value length as kernlen else \ We're still within $kernels parsing toward the end; \ find delimiter/end to determine kernlen 2dup ( c-addr/u -- c-addr/u c-addr/u ) begin dup 0<> while over c@ delim? if drop 0 ( break ) \ found delimiter else kernlen @ 1+ kernlen ! \ incrememnt 1- swap 1+ swap \ c-addr++ u-- then repeat 2drop ( c-addr/u c-addr'/u' -- c-addr/u ) \ If this is the first entry, compare it to $kernel \ If different, then insert $kernel beforehand kernmenuidx @ [char] 0 = if over kernlen @ kerndefault count compare if kernelsbuf 0 kerndefault count strcat s" ," strcat 2swap strcat kerndefault count swap drop kernlen ! then then then ( c-addr/u -- c-addr'/u' ) \ At this point, we should have something on the stack to store \ as the next kernel menu option; start assembling variables over kernlen @ ( c-addr/u -- c-addr/u c-addr/u2 ) \ Assign first to kernel[x] 2dup kernmenuidx @ kernel[x] setenv \ Assign second to menu_caption[x][y] kerncapbuf 0 s" [K]ernel: " strcat 2over strcat kernidx @ kernmenuidx @ menu_caption[x][y] setenv \ Assign third to ansi_caption[x][y] kerncapbuf 0 s" Kernel: " strcat kernmenuidx @ [char] 0 = if s" default/" else s" " then strcat 2over strcat s" " strcat kernidx @ kernmenuidx @ ansi_caption[x][y] setenv 2drop ( c-addr/u c-addr/u2 -- c-addr/u ) kernmenuidx @ 1+ dup kernmenuidx ! [char] 8 > if 2drop ( c-addr/u -- ) exit then kernlen @ - swap kernlen @ + swap ( c-addr/u -- c-addr'/u' ) again ; \ This function goes through the kernels that were discovered by the \ parse-kernels function [above], adding " (# of #)" text to the end of each \ caption. \ : tag-kernels ( -- ) kernidx @ ( -- x ) dup 0= if exit then [char] 0 s" (Y of Z)" ( x -- x y c-addr/u ) kernmenuidx @ -rot 7 +c! \ Replace 'Z' with number of kernels parsed begin 2 pick 1+ -rot 2 +c! \ Replace 'Y' with current ASCII num 2over menu_caption[x][y] getenv dup -1 <> if 2dup + 1- c@ [char] ) = if 2drop \ Already tagged else kerncapbuf 0 2swap strcat 2over strcat 5 pick 5 pick menu_caption[x][y] setenv then else drop ( getenv cruft ) then 2over ansi_caption[x][y] getenv dup -1 <> if 2dup + 1- c@ [char] ) = if 2drop \ Already tagged else kerncapbuf 0 2swap strcat 2over strcat 5 pick 5 pick ansi_caption[x][y] setenv then else drop ( getenv cruft ) then rot 1+ dup [char] 8 > if -rot 2drop TRUE ( break ) else -rot FALSE then until 2drop ( x y -- ) ; \ This function creates the list of menu items. This function is called by the \ menu-display function. You need not call it directly. \ : menu-create ( -- ) \ Print the frame caption at (x,y) s" loader_menu_title" getenv dup -1 = if drop s" Welcome to FreeBSD" then TRUE ( use default alignment ) s" loader_menu_title_align" getenv dup -1 <> if 2dup s" left" compare-insensitive 0= if ( 1 ) 2drop ( c-addr/u ) drop ( bool ) menuX @ menuY @ 1- FALSE ( don't use default alignment ) else ( 1 ) 2dup s" right" compare-insensitive 0= if ( 2 ) 2drop ( c-addr/u ) drop ( bool ) menuX @ 42 + 4 - over - menuY @ 1- FALSE ( don't use default alignment ) else ( 2 ) 2drop ( c-addr/u ) then ( 1 ) then else drop ( getenv cruft ) then if ( use default center alignement? ) menuX @ 19 + over 2 / - menuY @ 1- then at-xy type \ If $menu_init is set, evaluate it (allowing for whole menus to be \ constructed dynamically -- as this function could conceivably set \ the remaining environment variables to construct the menu entirely). \ s" menu_init" getenv dup -1 <> if evaluate else drop then \ Print our menu options with respective key/variable associations. \ `printmenuitem' ends by adding the decimal ASCII value for the \ numerical prefix to the stack. We store the value left on the stack \ to the key binding variable for later testing against a character \ captured by the `getkey' function. \ Note that any menu item beyond 9 will have a numerical prefix on the \ screen consisting of the first digit (ie. 1 for the tenth menu item) \ and the key required to activate that menu item will be the decimal \ ASCII of 48 plus the menu item (ie. 58 for the tenth item, aka. `:') \ which is misleading and not desirable. \ \ Thus, we do not allow more than 8 configurable items on the menu \ (with "Reboot" as the optional ninth and highest numbered item). \ \ Initialize the ACPI option status. \ 0 menuacpi ! s" menu_acpi" getenv -1 <> if c@ dup 48 > over 57 < and if ( '1' <= c1 <= '8' ) menuacpi ! arch-i386? if acpipresent? if \ \ Set menu toggle state to active state \ (required by generic toggle_menuitem) \ acpienabled? menuacpi @ toggle_stateN ! then then else drop then then \ \ Initialize kernel captions after parsing $kernels \ 0 menukernel ! s" menu_kernel" getenv -1 <> if c@ dup 48 > over 57 < and if ( '1' <= c1 <= '8' ) dup menukernel ! dup parse-kernels tag-kernels \ Get the current cycle state (entry to use) s" kernel_state" evaluate @ 48 + ( n -- n y ) \ If state is invalid, reset dup kernmenuidx @ 1- > if drop [char] 0 ( n y -- n 48 ) 0 s" kernel_state" evaluate ! over s" init_kernel" evaluate drop then \ Set the current non-ANSI caption 2dup swap dup ( n y -- n y y n n ) s" set menu_caption[x]=$menu_caption[x][y]" 17 +c! 34 +c! 37 +c! evaluate ( n y y n n c-addr/u -- n y ) \ Set the current ANSI caption 2dup swap dup ( n y -- n y y n n ) s" set ansi_caption[x]=$ansi_caption[x][y]" 17 +c! 34 +c! 37 +c! evaluate ( n y y n n c-addr/u -- n y ) \ Initialize cycle state from stored value 48 - ( n y -- n k ) s" init_cyclestate" evaluate ( n k -- n ) \ Set $kernel to $kernel[y] s" activate_kernel" evaluate ( n -- n ) then drop then \ \ Initialize the menu_options visual separator. \ 0 menuoptions ! s" menu_options" getenv -1 <> if c@ dup 48 > over 57 < and if ( '1' <= c1 <= '8' ) menuoptions ! else drop then then \ Initialize "Reboot" menu state variable (prevents double-entry) false menurebootadded ! menu_start 1- menuidx ! \ Initialize the starting index for the menu 0 menurow ! \ Initialize the starting position for the menu 49 \ Iterator start (loop range 49 to 56; ASCII '1' to '8') begin \ If the "Options:" separator, print it. dup menuoptions @ = if \ Optionally add a reboot option to the menu s" menu_reboot" getenv -1 <> if drop s" Reboot" printmenuitem menureboot ! true menurebootadded ! then menuX @ menurow @ 2 + menurow ! menurow @ menuY @ + at-xy s" menu_optionstext" getenv dup -1 <> if type else drop ." Options:" then then \ If this is the ACPI menu option, act accordingly. dup menuacpi @ = if dup acpimenuitem ( n -- n n c-addr/u | n n -1 ) dup -1 <> if 13 +c! ( n n c-addr/u -- n c-addr/u ) \ replace 'x' with n else swap drop ( n n -1 -- n -1 ) over menu_command[x] unsetenv then else \ make sure we have not already initialized this item dup init_stateN dup @ 0= if 1 swap ! \ If this menuitem has an initializer, run it dup menu_init[x] getenv dup -1 <> if evaluate else drop then else drop then dup loader_color? if ansi_caption[x] else menu_caption[x] then then dup -1 <> if \ test for environment variable getenv dup -1 <> if printmenuitem ( c-addr/u -- n ) dup menukeyN ! else drop then else drop then 1+ dup 56 > \ add 1 to iterator, continue if less than 57 until drop \ iterator \ Optionally add a reboot option to the menu menurebootadded @ true <> if s" menu_reboot" getenv -1 <> if drop \ no need for the value s" Reboot" \ menu caption (required by printmenuitem) printmenuitem menureboot ! else 0 menureboot ! then then ; \ Takes a single integer on the stack and updates the timeout display. The \ integer must be between 0 and 9 (we will only update a single digit in the \ source message). \ : menu-timeout-update ( N -- ) \ Enforce minimum/maximum dup 9 > if drop 9 then dup 0 < if drop 0 then s" Autoboot in N seconds. [Space] to pause" ( n -- n c-addr/u ) 2 pick 0> if rot 48 + -rot ( n c-addr/u -- n' c-addr/u ) \ convert to ASCII 12 +c! ( n' c-addr/u -- c-addr/u ) \ replace 'N' above menu_timeout_x @ menu_timeout_y @ at-xy \ position cursor type ( c-addr/u -- ) \ print message else menu_timeout_x @ menu_timeout_y @ at-xy \ position cursor spaces ( n c-addr/u -- n c-addr ) \ erase message 2drop ( n c-addr -- ) then 0 25 at-xy ( position cursor back at bottom-left ) ; \ This function blocks program flow (loops forever) until a key is pressed. \ The key that was pressed is added to the top of the stack in the form of its \ decimal ASCII representation. This function is called by the menu-display \ function. You need not call it directly. \ : getkey ( -- ascii_keycode ) begin \ loop forever menu_timeout_enabled @ 1 = if ( -- ) seconds ( get current time: -- N ) dup menu_time @ <> if ( has time elapsed?: N N N -- N ) \ At least 1 second has elapsed since last loop \ so we will decrement our "timeout" (really a \ counter, insuring that we do not proceed too \ fast) and update our timeout display. menu_time ! ( update time record: N -- ) menu_timeout @ ( "time" remaining: -- N ) dup 0> if ( greater than 0?: N N 0 -- N ) 1- ( decrement counter: N -- N ) dup menu_timeout ! ( re-assign: N N Addr -- N ) then ( -- N ) dup 0= swap 0< or if ( N <= 0?: N N -- ) \ halt the timer 0 menu_timeout ! ( 0 Addr -- ) 0 menu_timeout_enabled ! ( 0 Addr -- ) then \ update the timer display ( N -- ) menu_timeout @ menu-timeout-update menu_timeout @ 0= if \ We've reached the end of the timeout \ (user did not cancel by pressing ANY \ key) s" menu_timeout_command" getenv dup -1 = if drop \ clean-up else evaluate then then else ( -- N ) \ No [detectable] time has elapsed (in seconds) drop ( N -- ) then ( -- ) then key? if \ Was a key pressed? (see loader(8)) \ An actual key was pressed (if the timeout is running, \ kill it regardless of which key was pressed) menu_timeout @ 0<> if 0 menu_timeout ! 0 menu_timeout_enabled ! \ clear screen of timeout message 0 menu-timeout-update then \ get the key that was pressed and exit (if we \ get a non-zero ASCII code) key dup 0<> if exit else drop then then 50 ms \ sleep for 50 milliseconds (see loader(8)) again ; : menu-erase ( -- ) \ Erases menu and resets positioning variable to positon 1. \ Clear the screen area associated with the interactive menu menuX @ menuY @ 2dup at-xy 38 spaces 1+ 2dup at-xy 38 spaces 1+ 2dup at-xy 38 spaces 1+ 2dup at-xy 38 spaces 1+ 2dup at-xy 38 spaces 1+ 2dup at-xy 38 spaces 1+ 2dup at-xy 38 spaces 1+ 2dup at-xy 38 spaces 1+ 2dup at-xy 38 spaces 1+ 2dup at-xy 38 spaces 1+ 2dup at-xy 38 spaces 1+ 2dup at-xy 38 spaces 2drop \ Reset the starting index and position for the menu menu_start 1- menuidx ! 0 menurow ! ; +only forth +also menu-infrastructure +also menu-namespace +also menu-command-helpers definitions + +: toggle_menuitem ( N -- N ) \ toggles caption text and internal menuitem state + + \ ASCII numeral equal to user-selected menu item must be on the stack. + \ We do not modify the stack, so the ASCII numeral is left on top. + + dup init_textN c@ 0= if + \ NOTE: no need to check toggle_stateN since the first time we + \ are called, we will populate init_textN. Further, we don't + \ need to test whether menu_caption[x] (ansi_caption[x] when + \ loader_color?=1) is available since we would not have been + \ called if the caption was NULL. + + \ base name of environment variable + dup ( n -- n n ) \ key pressed + loader_color? if + ansi_caption[x] + else + menu_caption[x] + then + getenv dup -1 <> if + + 2 pick ( n c-addr/u -- n c-addr/u n ) + init_textN ( n c-addr/u n -- n c-addr/u c-addr ) + + \ now we have the buffer c-addr on top + \ ( followed by c-addr/u of current caption ) + + \ Copy the current caption into our buffer + 2dup c! -rot \ store strlen at first byte + begin + rot 1+ \ bring alt addr to top and increment + -rot -rot \ bring buffer addr to top + 2dup c@ swap c! \ copy current character + 1+ \ increment buffer addr + rot 1- \ bring buffer len to top and decrement + dup 0= \ exit loop if buffer len is zero + until + 2drop \ buffer len/addr + drop \ alt addr + + else + drop + then + then + + \ Now we are certain to have init_textN populated with the initial + \ value of menu_caption[x] (ansi_caption[x] with loader_color enabled). + \ We can now use init_textN as the untoggled caption and + \ toggled_text[x] (toggled_ansi[x] with loader_color enabled) as the + \ toggled caption and store the appropriate value into menu_caption[x] + \ (again, ansi_caption[x] with loader_color enabled). Last, we'll + \ negate the toggled state so that we reverse the flow on subsequent + \ calls. + + dup toggle_stateN @ 0= if + \ state is OFF, toggle to ON + + dup ( n -- n n ) \ key pressed + loader_color? if + toggled_ansi[x] + else + toggled_text[x] + then + getenv dup -1 <> if + \ Assign toggled text to menu caption + 2 pick ( n c-addr/u -- n c-addr/u n ) \ key pressed + loader_color? if + ansi_caption[x] + else + menu_caption[x] + then + setenv + else + \ No toggled text, keep the same caption + drop ( n -1 -- n ) \ getenv cruft + then + + true \ new value of toggle state var (to be stored later) + else + \ state is ON, toggle to OFF + + dup init_textN count ( n -- n c-addr/u ) + + \ Assign init_textN text to menu caption + 2 pick ( n c-addr/u -- n c-addr/u n ) \ key pressed + loader_color? if + ansi_caption[x] + else + menu_caption[x] + then + setenv + + false \ new value of toggle state var (to be stored below) + then + + \ now we'll store the new toggle state (on top of stack) + over toggle_stateN ! +; + +: cycle_menuitem ( N -- N ) \ cycles through array of choices for a menuitem + + \ ASCII numeral equal to user-selected menu item must be on the stack. + \ We do not modify the stack, so the ASCII numeral is left on top. + + dup cycle_stateN dup @ 1+ \ get value and increment + + \ Before assigning the (incremented) value back to the pointer, + \ let's test for the existence of this particular array element. + \ If the element exists, we'll store index value and move on. + \ Otherwise, we'll loop around to zero and store that. + + dup 48 + ( n addr k -- n addr k k' ) + \ duplicate array index and convert to ASCII numeral + + 3 pick swap ( n addr k k' -- n addr k n k' ) \ (n,k') as (x,y) + loader_color? if + ansi_caption[x][y] + else + menu_caption[x][y] + then + ( n addr k n k' -- n addr k c-addr/u ) + + \ Now test for the existence of our incremented array index in the + \ form of $menu_caption[x][y] ($ansi_caption[x][y] with loader_color + \ enabled) as set in loader.rc(5), et. al. + + getenv dup -1 = if + \ No caption set for this array index. Loop back to zero. + + drop ( n addr k -1 -- n addr k ) \ getenv cruft + drop 0 ( n addr k -- n addr 0 ) \ new value to store later + + 2 pick [char] 0 ( n addr 0 -- n addr 0 n 48 ) \ (n,48) as (x,y) + loader_color? if + ansi_caption[x][y] + else + menu_caption[x][y] + then + ( n addr 0 n 48 -- n addr 0 c-addr/u ) + getenv dup -1 = if + \ Highly unlikely to occur, but to ensure things move + \ along smoothly, allocate a temporary NULL string + drop ( cruft ) s" " + then + then + + \ At this point, we should have the following on the stack (in order, + \ from bottom to top): + \ + \ n - Ascii numeral representing the menu choice (inherited) + \ addr - address of our internal cycle_stateN variable + \ k - zero-based number we intend to store to the above + \ c-addr/u - string value we intend to store to menu_caption[x] + \ (or ansi_caption[x] with loader_color enabled) + \ + \ Let's perform what we need to with the above. + + \ Assign array value text to menu caption + 4 pick ( n addr k c-addr/u -- n addr k c-addr/u n ) + loader_color? if + ansi_caption[x] + else + menu_caption[x] + then + setenv + + swap ! ( n addr k -- n ) \ update array state variable +; + +only forth definitions also menu-infrastructure + \ Erase and redraw the menu. Useful if you change a caption and want to \ update the menu to reflect the new value. \ : menu-redraw ( -- ) menu-erase menu-create ; \ This function initializes the menu. Call this from your `loader.rc' file \ before calling any other menu-related functions. \ : menu-init ( -- ) menu_start 1- menuidx ! \ Initialize the starting index for the menu 0 menurow ! \ Initialize the starting position for the menu \ Assign configuration values s" loader_menu_y" getenv dup -1 = if drop \ no custom row position menu_default_y else \ make sure custom position is a number ?number 0= if menu_default_y \ or use default then then menuY ! s" loader_menu_x" getenv dup -1 = if drop \ no custom column position menu_default_x else \ make sure custom position is a number ?number 0= if menu_default_x \ or use default then then menuX ! \ Interpret a custom frame type for the menu TRUE ( draw a box? default yes, but might be altered below ) s" loader_menu_frame" getenv dup -1 = if ( 1 ) drop \ no custom frame type else ( 1 ) 2dup s" single" compare-insensitive 0= if ( 2 ) f_single ( see frames.4th ) else ( 2 ) 2dup s" double" compare-insensitive 0= if ( 3 ) f_double ( see frames.4th ) else ( 3 ) s" none" compare-insensitive 0= if ( 4 ) drop FALSE \ don't draw a box ( 4 ) then ( 3 ) then ( 2 ) then ( 1 ) then if 42 13 menuX @ 3 - menuY @ 1- box \ Draw frame (w,h,x,y) then 0 25 at-xy \ Move cursor to the bottom for output ; +also menu-namespace + \ Main function. Call this from your `loader.rc' file. \ : menu-display ( -- ) 0 menu_timeout_enabled ! \ start with automatic timeout disabled \ check indication that automatic execution after delay is requested s" menu_timeout_command" getenv -1 <> if ( Addr C -1 -- | Addr ) drop ( just testing existence right now: Addr -- ) \ initialize state variables seconds menu_time ! ( store the time we started ) 1 menu_timeout_enabled ! ( enable automatic timeout ) \ read custom time-duration (if set) s" autoboot_delay" getenv dup -1 = if drop \ no custom duration (remove dup'd bunk -1) menu_timeout_default \ use default setting else 2dup ?number 0= if ( if not a number ) \ disable timeout if "NO", else use default s" NO" compare-insensitive 0= if 0 menu_timeout_enabled ! 0 ( assigned to menu_timeout below ) else menu_timeout_default then else -rot 2drop \ boot immediately if less than zero dup 0< if drop menu-create 0 25 at-xy 0 boot then then then menu_timeout ! ( store value on stack from above ) menu_timeout_enabled @ 1 = if \ read custom column position (if set) s" loader_menu_timeout_x" getenv dup -1 = if drop \ no custom column position menu_timeout_default_x \ use default setting else \ make sure custom position is a number ?number 0= if menu_timeout_default_x \ or use default then then menu_timeout_x ! ( store value on stack from above ) \ read custom row position (if set) s" loader_menu_timeout_y" getenv dup -1 = if drop \ no custom row position menu_timeout_default_y \ use default setting else \ make sure custom position is a number ?number 0= if menu_timeout_default_y \ or use default then then menu_timeout_y ! ( store value on stack from above ) then then menu-create begin \ Loop forever 0 25 at-xy \ Move cursor to the bottom for output getkey \ Block here, waiting for a key to be pressed dup -1 = if drop exit \ Caught abort (abnormal return) then \ Boot if the user pressed Enter/Ctrl-M (13) or \ Ctrl-Enter/Ctrl-J (10) dup over 13 = swap 10 = or if drop ( no longer needed ) s" boot" evaluate exit ( pedantic; never reached ) then dup menureboot @ = if 0 reboot then \ Evaluate the decimal ASCII value against known menu item \ key associations and act accordingly 49 \ Iterator start (loop range 49 to 56; ASCII '1' to '8') begin dup menukeyN @ rot tuck = if \ Adjust for missing ACPI menuitem on non-i386 arch-i386? true <> menuacpi @ 0<> and if menuacpi @ over 2dup < -rot = or over 58 < and if ( key >= menuacpi && key < 58: N -- N ) 1+ then then \ Test for the environment variable dup menu_command[x] getenv dup -1 <> if \ Execute the stored procedure evaluate \ We expect there to be a non-zero \ value left on the stack after \ executing the stored procedure. \ If so, continue to run, else exit. 0= if drop \ key pressed drop \ loop iterator exit else swap \ need iterator on top then then \ Re-adjust for missing ACPI menuitem arch-i386? true <> menuacpi @ 0<> and if swap menuacpi @ 1+ over 2dup < -rot = or over 59 < and if 1- then swap then else swap \ need iterator on top then \ \ Check for menu keycode shortcut(s) \ dup menu_keycode[x] getenv dup -1 = if drop else ?number 0<> if rot tuck = if swap dup menu_command[x] getenv dup -1 <> if evaluate 0= if 2drop exit then else drop then else swap then then then 1+ dup 56 > \ increment iterator \ continue if less than 57 until drop \ loop iterator drop \ key pressed again \ Non-operational key was pressed; repeat ; \ This function unsets all the possible environment variables associated with \ creating the interactive menu. \ : menu-unset ( -- ) 49 \ Iterator start (loop range 49 to 56; ASCII '1' to '8') begin dup menu_init[x] unsetenv \ menu initializer dup menu_command[x] unsetenv \ menu command dup menu_caption[x] unsetenv \ menu caption dup ansi_caption[x] unsetenv \ ANSI caption dup menu_keycode[x] unsetenv \ menu keycode dup toggled_text[x] unsetenv \ toggle_menuitem caption dup toggled_ansi[x] unsetenv \ toggle_menuitem ANSI caption 48 \ Iterator start (inner range 48 to 57; ASCII '0' to '9') begin \ cycle_menuitem caption and ANSI caption 2dup menu_caption[x][y] unsetenv 2dup ansi_caption[x][y] unsetenv 1+ dup 57 > until drop \ inner iterator 0 over menukeyN ! \ used by menu-create, menu-display 0 over init_stateN ! \ used by menu-create 0 over toggle_stateN ! \ used by toggle_menuitem 0 over init_textN c! \ used by toggle_menuitem 0 over cycle_stateN ! \ used by cycle_menuitem 1+ dup 56 > \ increment, continue if less than 57 until drop \ iterator s" menu_timeout_command" unsetenv \ menu timeout command s" menu_reboot" unsetenv \ Reboot menu option flag s" menu_acpi" unsetenv \ ACPI menu option flag s" menu_kernel" unsetenv \ Kernel menu option flag s" menu_options" unsetenv \ Options separator flag s" menu_optionstext" unsetenv \ separator display text s" menu_init" unsetenv \ menu initializer 0 menureboot ! 0 menuacpi ! 0 menuoptions ! ; +only forth definitions also menu-infrastructure + \ This function both unsets menu variables and visually erases the menu area \ in-preparation for another menu. \ : menu-clear ( -- ) menu-unset menu-erase ; bullet menubllt ! +also menu-namespace + \ Initialize our menu initialization state variables 0 init_state1 ! 0 init_state2 ! 0 init_state3 ! 0 init_state4 ! 0 init_state5 ! 0 init_state6 ! 0 init_state7 ! 0 init_state8 ! \ Initialize our boolean state variables 0 toggle_state1 ! 0 toggle_state2 ! 0 toggle_state3 ! 0 toggle_state4 ! 0 toggle_state5 ! 0 toggle_state6 ! 0 toggle_state7 ! 0 toggle_state8 ! \ Initialize our array state variables 0 cycle_state1 ! 0 cycle_state2 ! 0 cycle_state3 ! 0 cycle_state4 ! 0 cycle_state5 ! 0 cycle_state6 ! 0 cycle_state7 ! 0 cycle_state8 ! \ Initialize string containers 0 init_text1 c! 0 init_text2 c! 0 init_text3 c! 0 init_text4 c! 0 init_text5 c! 0 init_text6 c! 0 init_text7 c! 0 init_text8 c! + +only forth definitions Index: head/sys/boot/forth/menusets.4th =================================================================== --- head/sys/boot/forth/menusets.4th (revision 280936) +++ head/sys/boot/forth/menusets.4th (revision 280937) @@ -1,617 +1,624 @@ \ Copyright (c) 2012 Devin Teske \ All rights reserved. \ \ Redistribution and use in source and binary forms, with or without \ modification, are permitted provided that the following conditions \ are met: \ 1. Redistributions of source code must retain the above copyright \ notice, this list of conditions and the following disclaimer. \ 2. Redistributions in binary form must reproduce the above copyright \ notice, this list of conditions and the following disclaimer in the \ documentation and/or other materials provided with the distribution. \ \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF \ SUCH DAMAGE. \ \ $FreeBSD$ marker task-menusets.4th +vocabulary menusets-infrastructure +only forth also menusets-infrastructure definitions + variable menuset_use_name create menuset_affixbuf 255 allot create menuset_x 1 allot create menuset_y 1 allot : menuset-loadvar ( -- ) \ menuset_use_name is true or false \ $type should be set to one of: \ menu toggled ansi \ $var should be set to one of: \ caption command keycode text ... \ $affix is either prefix (menuset_use_name is true) \ or infix (menuset_use_name is false) s" set cmdbuf='set ${type}_${var}=\$'" evaluate s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length menuset_use_name @ true = if s" set cmdbuf=${cmdbuf}${affix}${type}_${var}" ( u1 -- u1 c-addr2 u2 ) else s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}" ( u1 -- u1 c-addr2 u2 ) then evaluate ( u1 c-addr2 u2 -- u1 ) s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 ) rot 2 pick 2 pick over + -rot + tuck - ( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 ) \ Generate a string representing rvalue inheritance var getenv dup -1 = if ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 ) \ NOT set -- clean up the stack drop ( c-addr2 u2 -1 -- c-addr2 u2 ) 2drop ( c-addr2 u2 -- ) else ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 ) \ SET -- execute cmdbuf (c-addr2/u2) to inherit value 2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 ) evaluate ( c-addr2 u2 -- ) then s" cmdbuf" unsetenv ; : menuset-unloadvar ( -- ) \ menuset_use_name is true or false \ $type should be set to one of: \ menu toggled ansi \ $var should be set to one of: \ caption command keycode text ... \ $affix is either prefix (menuset_use_name is true) \ or infix (menuset_use_name is false) menuset_use_name @ true = if s" set buf=${affix}${type}_${var}" else s" set buf=${type}set${affix}_${var}" then evaluate s" buf" getenv unsetenv s" buf" unsetenv ; : menuset-loadmenuvar ( -- ) s" set type=menu" evaluate menuset-loadvar ; : menuset-unloadmenuvar ( -- ) s" set type=menu" evaluate menuset-unloadvar ; : menuset-loadxvar ( -- ) \ menuset_use_name is true or false \ $type should be set to one of: \ menu toggled ansi \ $var should be set to one of: \ caption command keycode text ... \ $x is "1" through "8" \ $affix is either prefix (menuset_use_name is true) \ or infix (menuset_use_name is false) s" set cmdbuf='set ${type}_${var}[${x}]=\$'" evaluate s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length menuset_use_name @ true = if s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}]" ( u1 -- u1 c-addr2 u2 ) else s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}]" ( u1 -- u1 c-addr2 u2 ) then evaluate ( u1 c-addr2 u2 -- u1 ) s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 ) rot 2 pick 2 pick over + -rot + tuck - ( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 ) \ Generate a string representing rvalue inheritance var getenv dup -1 = if ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 ) \ NOT set -- clean up the stack drop ( c-addr2 u2 -1 -- c-addr2 u2 ) 2drop ( c-addr2 u2 -- ) else ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 ) \ SET -- execute cmdbuf (c-addr2/u2) to inherit value 2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 ) evaluate ( c-addr2 u2 -- ) then s" cmdbuf" unsetenv ; : menuset-unloadxvar ( -- ) \ menuset_use_name is true or false \ $type should be set to one of: \ menu toggled ansi \ $var should be set to one of: \ caption command keycode text ... \ $x is "1" through "8" \ $affix is either prefix (menuset_use_name is true) \ or infix (menuset_use_name is false) menuset_use_name @ true = if s" set buf=${affix}${type}_${var}[${x}]" else s" set buf=${type}set${affix}_${var}[${x}]" then evaluate s" buf" getenv unsetenv s" buf" unsetenv ; : menuset-loadansixvar ( -- ) s" set type=ansi" evaluate menuset-loadxvar ; : menuset-unloadansixvar ( -- ) s" set type=ansi" evaluate menuset-unloadxvar ; : menuset-loadmenuxvar ( -- ) s" set type=menu" evaluate menuset-loadxvar ; : menuset-unloadmenuxvar ( -- ) s" set type=menu" evaluate menuset-unloadxvar ; : menuset-loadtoggledxvar ( -- ) s" set type=toggled" evaluate menuset-loadxvar ; : menuset-unloadtoggledxvar ( -- ) s" set type=toggled" evaluate menuset-unloadxvar ; : menuset-loadxyvar ( -- ) \ menuset_use_name is true or false \ $type should be set to one of: \ menu toggled ansi \ $var should be set to one of: \ caption command keycode text ... \ $x is "1" through "8" \ $y is "0" through "9" \ $affix is either prefix (menuset_use_name is true) \ or infix (menuset_use_name is false) s" set cmdbuf='set ${type}_${var}[${x}][${y}]=\$'" evaluate s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length menuset_use_name @ true = if s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}][${y}]" ( u1 -- u1 c-addr2 u2 ) else s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}][${y}]" ( u1 -- u1 c-addr2 u2 ) then evaluate ( u1 c-addr2 u2 -- u1 ) s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 ) rot 2 pick 2 pick over + -rot + tuck - ( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 ) \ Generate a string representing rvalue inheritance var getenv dup -1 = if ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 ) \ NOT set -- clean up the stack drop ( c-addr2 u2 -1 -- c-addr2 u2 ) 2drop ( c-addr2 u2 -- ) else ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 ) \ SET -- execute cmdbuf (c-addr2/u2) to inherit value 2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 ) evaluate ( c-addr2 u2 -- ) then s" cmdbuf" unsetenv ; : menuset-unloadxyvar ( -- ) \ menuset_use_name is true or false \ $type should be set to one of: \ menu toggled ansi \ $var should be set to one of: \ caption command keycode text ... \ $x is "1" through "8" \ $y is "0" through "9" \ $affix is either prefix (menuset_use_name is true) \ or infix (menuset_use_name is false) menuset_use_name @ true = if s" set buf=${affix}${type}_${var}[${x}][${y}]" else s" set buf=${type}set${affix}_${var}[${x}][${y}]" then evaluate s" buf" getenv unsetenv s" buf" unsetenv ; : menuset-loadansixyvar ( -- ) s" set type=ansi" evaluate menuset-loadxyvar ; : menuset-unloadansixyvar ( -- ) s" set type=ansi" evaluate menuset-unloadxyvar ; : menuset-loadmenuxyvar ( -- ) s" set type=menu" evaluate menuset-loadxyvar ; : menuset-unloadmenuxyvar ( -- ) s" set type=menu" evaluate menuset-unloadxyvar ; : menuset-setnum-namevar ( N -- C-Addr/U ) s" menuset_nameNNNNN" ( n -- n c-addr1 u1 ) \ variable basename drop 12 ( n c-addr1 u1 -- n c-addr1 12 ) \ remove "NNNNN" rot ( n c-addr1 12 -- c-addr1 12 n ) \ move number on top \ convert to string s>d <# #s #> ( c-addr1 12 n -- c-addr1 12 c-addr2 u2 ) \ Combine strings begin ( using u2 in c-addr2/u2 pair as countdown to zero ) over ( c-addr1 u1 c-addr2 u2 -- continued below ) ( c-addr1 u1 c-addr2 u2 c-addr2 ) \ copy src-addr c@ ( c-addr1 u1 c-addr2 u2 c-addr2 -- continued below ) ( c-addr1 u1 c-addr2 u2 c ) \ get next src-addr byte 4 pick 4 pick ( c-addr1 u1 c-addr2 u2 c -- continued below ) ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 ) \ get destination c-addr1/u1 pair + ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- cont. below ) ( c-addr1 u1 c-addr2 u2 c c-addr3 ) \ combine dest-c-addr to get dest-addr for byte c! ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below ) ( c-addr1 u1 c-addr2 u2 ) \ store the current src-addr byte into dest-addr 2swap 1+ 2swap \ increment u1 in destination c-addr1/u1 pair swap 1+ swap \ increment c-addr2 in source c-addr2/u2 pair 1- \ decrement u2 in the source c-addr2/u2 pair dup 0= \ time to break? until 2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 ) \ drop temporary number-format conversion c-addr2/u2 ; : menuset-checksetnum ( N -- ) \ \ adjust input to be both positive and no-higher than 65535 \ abs dup 65535 > if drop 65535 then ( n -- n ) \ \ The next few blocks will determine if we should use the default \ methodology (referencing the original numeric stack-input), or if- \ instead $menuset_name{N} has been defined wherein we would then \ use the value thereof as the prefix to every menu variable. \ false menuset_use_name ! \ assume name is not set menuset-setnum-namevar \ \ We now have a string that is the assembled variable name to check \ for... $menuset_name{N}. Let's check for it. \ 2dup ( c-addr1 u1 -- c-addr1 u1 c-addr1 u1 ) \ save a copy getenv dup -1 <> if ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 c-addr2 u2 ) \ The variable is set. Let's clean up the stack leaving only \ its value for later use. true menuset_use_name ! 2swap 2drop ( c-addr1 u1 c-addr2 u2 -- c-addr2 u2 ) \ drop assembled variable name, leave the value else ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 -1 ) \ no such variable \ The variable is not set. Let's clean up the stack leaving the \ string [portion] representing the original numeric input. drop ( c-addr1 u1 -1 -- c-addr1 u1 ) \ drop -1 result 12 - swap 12 + swap ( c-addr1 u1 -- c-addr2 u2 ) \ truncate to original numeric stack-input then \ \ Now, depending on whether $menuset_name{N} has been set, we have \ either the value thereof to be used as a prefix to all menu_* \ variables or we have a string representing the numeric stack-input \ to be used as a "set{N}" infix to the same menu_* variables. \ \ For example, if the stack-input is 1 and menuset_name1 is NOT set \ the following variables will be referenced: \ ansiset1_caption[x] -> ansi_caption[x] \ ansiset1_caption[x][y] -> ansi_caption[x][y] \ menuset1_acpi -> menu_acpi \ menuset1_caption[x] -> menu_caption[x] \ menuset1_caption[x][y] -> menu_caption[x][y] \ menuset1_command[x] -> menu_command[x] \ menuset1_init -> ``evaluated'' \ menuset1_init[x] -> menu_init[x] \ menuset1_kernel -> menu_kernel \ menuset1_keycode[x] -> menu_keycode[x] \ menuset1_options -> menu_options \ menuset1_optionstext -> menu_optionstext \ menuset1_reboot -> menu_reboot \ toggledset1_ansi[x] -> toggled_ansi[x] \ toggledset1_text[x] -> toggled_text[x] \ otherwise, the following variables are referenced (where {name} \ represents the value of $menuset_name1 (given 1 as stack-input): \ {name}ansi_caption[x] -> ansi_caption[x] \ {name}ansi_caption[x][y] -> ansi_caption[x][y] \ {name}menu_acpi -> menu_acpi \ {name}menu_caption[x] -> menu_caption[x] \ {name}menu_caption[x][y] -> menu_caption[x][y] \ {name}menu_command[x] -> menu_command[x] \ {name}menu_init -> ``evaluated'' \ {name}menu_init[x] -> menu_init[x] \ {name}menu_kernel -> menu_kernel \ {name}menu_keycode[x] -> menu_keycode[x] \ {name}menu_options -> menu_options \ {name}menu_optionstext -> menu_optionstext \ {name}menu_reboot -> menu_reboot \ {name}toggled_ansi[x] -> toggled_ansi[x] \ {name}toggled_text[x] -> toggled_text[x] \ \ Note that menuset{N}_init and {name}menu_init are the initializers \ for the entire menu (for wholly dynamic menus) opposed to the per- \ menuitem initializers (with [x] afterward). The whole-menu init \ routine is evaluated and not passed down to $menu_init (which \ would result in double evaluation). By doing this, the initializer \ can initialize the menuset before we transfer it to active-duty. \ \ \ Copy our affixation (prefix or infix depending on menuset_use_name) \ to our buffer so that we can safely use the s-quote (s") buf again. \ menuset_affixbuf 0 2swap ( c-addr2 u2 -- c-addr1 0 c-addr2 u2 ) begin ( using u2 in c-addr2/u2 pair as countdown to zero ) over ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c-addr2 ) c@ ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c ) 4 pick 4 pick ( c-addr1 u1 c-addr2 u2 c -- continued below ) ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 ) + ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- continued below ) ( c-addr1 u1 c-addr2 u2 c c-addr3 ) c! ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below ) ( c-addr1 u1 c-addr2 u2 ) 2swap 1+ 2swap \ increment affixbuf byte position/count swap 1+ swap \ increment strbuf pointer (source c-addr2) 1- \ decrement strbuf byte count (source u2) dup 0= \ time to break? until 2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 ) \ drop strbuf c-addr2/u2 \ \ Create a variable for referencing our affix data (prefix or infix \ depending on menuset_use_name as described above). This variable will \ be temporary and only used to simplify cmdbuf assembly. \ s" affix" setenv ( c-addr1 u1 -- ) ; : menuset-cleanup ( -- ) s" type" unsetenv s" var" unsetenv s" x" unsetenv s" y" unsetenv s" affix" unsetenv ; +only forth definitions also menusets-infrastructure + : menuset-loadsetnum ( N -- ) menuset-checksetnum ( n -- ) \ \ From here out, we use temporary environment variables to make \ dealing with variable-length strings easier. \ \ menuset_use_name is true or false \ $affix should be used appropriately w/respect to menuset_use_name \ \ ... menu_init ... s" set var=init" evaluate menuset-loadmenuvar \ If menu_init was set by the above, evaluate it here-and-now \ so that the remaining variables are influenced by its actions s" menu_init" 2dup getenv dup -1 <> if 2swap unsetenv \ don't want later menu-create to re-call this evaluate else drop 2drop ( n c-addr u -1 -- n ) then [char] 1 ( -- x ) \ Loop range ASCII '1' (49) to '8' (56) begin dup menuset_x tuck c! 1 s" x" setenv \ set loop iterator and $x s" set var=caption" evaluate \ ... menu_caption[x] ... menuset-loadmenuxvar \ ... ansi_caption[x] ... menuset-loadansixvar [char] 0 ( x -- x y ) \ Inner Loop ASCII '1' (48) to '9' (57) begin dup menuset_y tuck c! 1 s" y" setenv \ set inner loop iterator and $y \ ... menu_caption[x][y] ... menuset-loadmenuxyvar \ ... ansi_caption[x][y] ... menuset-loadansixyvar 1+ dup 57 > ( x y -- y' 0|-1 ) \ increment and test until drop ( x y -- x ) \ ... menu_command[x] ... s" set var=command" evaluate menuset-loadmenuxvar \ ... menu_init[x] ... s" set var=init" evaluate menuset-loadmenuxvar \ ... menu_keycode[x] ... s" set var=keycode" evaluate menuset-loadmenuxvar \ ... toggled_text[x] ... s" set var=text" evaluate menuset-loadtoggledxvar \ ... toggled_ansi[x] ... s" set var=ansi" evaluate menuset-loadtoggledxvar 1+ dup 56 > ( x -- x' 0|-1 ) \ increment iterator \ continue if less than 57 until drop ( x -- ) \ loop iterator \ ... menu_reboot ... s" set var=reboot" evaluate menuset-loadmenuvar \ ... menu_acpi ... s" set var=acpi" evaluate menuset-loadmenuvar \ ... menu_kernel ... s" set var=kernel" evaluate menuset-loadmenuvar \ ... menu_options ... s" set var=options" evaluate menuset-loadmenuvar \ ... menu_optionstext ... s" set var=optionstext" evaluate menuset-loadmenuvar menuset-cleanup ; -: menuset-loadinitial ( -- ) - s" menuset_initial" getenv dup -1 <> if - ?number 0<> if - menuset-loadsetnum - then - else - drop \ cruft - then -; - : menusets-unset ( -- ) s" menuset_initial" unsetenv 1 begin dup menuset-checksetnum ( n n -- n ) dup menuset-setnum-namevar ( n n -- n ) unsetenv \ If the current menuset does not populate the first menuitem, \ we stop completely. menuset_use_name @ true = if s" set buf=${affix}menu_caption[1]" else s" set buf=menuset${affix}_caption[1]" then evaluate s" buf" getenv getenv -1 = if drop ( n -- ) s" buf" unsetenv menuset-cleanup exit else drop ( n c-addr2 -- n ) \ unused then [char] 1 ( n -- n x ) \ Loop range ASCII '1' (49) to '8' (56) begin dup menuset_x tuck c! 1 s" x" setenv \ set $x to x s" set var=caption" evaluate menuset-unloadmenuxvar menuset-unloadmenuxvar menuset-unloadansixvar [char] 0 ( n x -- n x y ) \ Inner loop '0' to '9' begin dup menuset_y tuck c! 1 s" y" setenv \ sets $y to y menuset-unloadmenuxyvar menuset-unloadansixyvar 1+ dup 57 > ( n x y -- n x y' 0|-1 ) until drop ( n x y -- n x ) s" set var=command" evaluate menuset-unloadmenuxvar s" set var=init" evaluate menuset-unloadmenuxvar s" set var=keycode" evaluate menuset-unloadmenuxvar s" set var=text" evaluate menuset-unloadtoggledxvar s" set var=ansi" evaluate menuset-unloadtoggledxvar 1+ dup 56 > ( x -- x' 0|-1 ) \ increment and test until drop ( n x -- n ) \ loop iterator s" set var=acpi" evaluate menuset-unloadmenuvar s" set var=init" evaluate menuset-unloadmenuvar s" set var=kernel" evaluate menuset-unloadmenuvar s" set var=options" evaluate menuset-unloadmenuvar s" set var=optionstext" evaluate menuset-unloadmenuvar s" set var=reboot" evaluate menuset-unloadmenuvar 1+ dup 65535 > ( n -- n' 0|-1 ) \ increment and test until drop ( n' -- ) \ loop iterator s" buf" unsetenv menuset-cleanup +; + +only forth definitions + +: menuset-loadinitial ( -- ) + s" menuset_initial" getenv dup -1 <> if + ?number 0<> if + menuset-loadsetnum + then + else + drop \ cruft + then ; Index: head/sys/boot/forth/support.4th =================================================================== --- head/sys/boot/forth/support.4th (revision 280936) +++ head/sys/boot/forth/support.4th (revision 280937) @@ -1,1586 +1,1583 @@ \ Copyright (c) 1999 Daniel C. Sobral \ All rights reserved. \ \ Redistribution and use in source and binary forms, with or without \ modification, are permitted provided that the following conditions \ are met: \ 1. Redistributions of source code must retain the above copyright \ notice, this list of conditions and the following disclaimer. \ 2. Redistributions in binary form must reproduce the above copyright \ notice, this list of conditions and the following disclaimer in the \ documentation and/or other materials provided with the distribution. \ \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF \ SUCH DAMAGE. \ \ $FreeBSD$ \ Loader.rc support functions: \ \ initialize ( addr len -- ) as above, plus load_conf_files \ load_conf ( addr len -- ) load conf file given \ include_conf_files ( -- ) load all conf files in load_conf_files \ print_syntax_error ( -- ) print line and marker of where a syntax \ error was detected \ print_line ( -- ) print last line processed \ load_kernel ( -- ) load kernel \ load_modules ( -- ) load modules flagged \ \ Exported structures: \ \ string counted string structure \ cell .addr string address \ cell .len string length \ module module loading information structure \ cell module.flag should we load it? \ string module.name module's name \ string module.loadname name to be used in loading the module \ string module.type module's type \ string module.args flags to be passed during load \ string module.beforeload command to be executed before load \ string module.afterload command to be executed after load \ string module.loaderror command to be executed if load fails \ cell module.next list chain \ \ Exported global variables; \ \ string conf_files configuration files to be loaded \ cell modules_options pointer to first module information \ value verbose? indicates if user wants a verbose loading \ value any_conf_read? indicates if a conf file was succesfully read \ \ Other exported words: \ note, strlen is internal \ strdup ( addr len -- addr' len) similar to strdup(3) \ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3) \ s' ( | string' -- addr len | ) similar to s" \ rudimentary structure support \ Exception values 1 constant ESYNTAX 2 constant ENOMEM 3 constant EFREE 4 constant ESETERROR \ error setting environment variable 5 constant EREAD \ error reading 6 constant EOPEN 7 constant EEXEC \ XXX never catched 8 constant EBEFORELOAD 9 constant EAFTERLOAD \ I/O constants 0 constant SEEK_SET 1 constant SEEK_CUR 2 constant SEEK_END 0 constant O_RDONLY 1 constant O_WRONLY 2 constant O_RDWR \ Crude structure support : structure: create here 0 , ['] drop , 0 does> create here swap dup @ allot cell+ @ execute ; : member: create dup , over , + does> cell+ @ + ; : ;structure swap ! ; : constructor! >body cell+ ! ; : constructor: over :noname ; : ;constructor postpone ; swap cell+ ! ; immediate : sizeof ' >body @ state @ if postpone literal then ; immediate : offsetof ' >body cell+ @ state @ if postpone literal then ; immediate : ptr 1 cells member: ; : int 1 cells member: ; \ String structure structure: string ptr .addr int .len constructor: 0 over .addr ! 0 swap .len ! ;constructor ;structure \ Module options linked list structure: module int module.flag sizeof string member: module.name sizeof string member: module.loadname sizeof string member: module.type sizeof string member: module.args sizeof string member: module.beforeload sizeof string member: module.afterload sizeof string member: module.loaderror ptr module.next ;structure \ Internal loader structures (preloaded_file, kernel_module, file_metadata) \ must be in sync with the C struct in sys/boot/common/bootstrap.h structure: preloaded_file ptr pf.name ptr pf.type ptr pf.args ptr pf.metadata \ file_metadata int pf.loader int pf.addr int pf.size ptr pf.modules \ kernel_module ptr pf.next \ preloaded_file ;structure structure: kernel_module ptr km.name \ ptr km.args ptr km.fp \ preloaded_file ptr km.next \ kernel_module ;structure structure: file_metadata int md.size 2 member: md.type \ this is not ANS Forth compatible (XXX) ptr md.next \ file_metadata 0 member: md.data \ variable size ;structure \ end of structures \ Global variables string conf_files string nextboot_conf_file create module_options sizeof module.next allot 0 module_options ! create last_module_option sizeof module.next allot 0 last_module_option ! 0 value verbose? 0 value nextboot? \ Support string functions : strdup { addr len -- addr' len' } len allocate if ENOMEM throw then addr over len move len ; : strcat { addr len addr' len' -- addr len+len' } addr' addr len + len' move addr len len' + ; : strchr { addr len c -- addr' len' } begin len while addr c@ c = if addr len exit then addr 1 + to addr len 1 - to len repeat 0 0 ; : s' \ same as s", allows " in the string [char] ' parse state @ if postpone sliteral then ; immediate : 2>r postpone >r postpone >r ; immediate : 2r> postpone r> postpone r> ; immediate : 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate : getenv? getenv -1 = if false else drop true then ; \ determine if a word appears in a string, case-insensitive : contains? ( addr1 len1 addr2 len2 -- 0 | -1 ) 2 pick 0= if 2drop 2drop true exit then dup 0= if 2drop 2drop false exit then begin begin swap dup c@ dup 32 = over 9 = or over 10 = or over 13 = or over 44 = or swap drop while 1+ swap 1- repeat swap 2 pick 1- over < while 2over 2over drop over compare-insensitive 0= if 2 pick over = if 2drop 2drop true exit then 2 pick tuck - -rot + swap over c@ dup 32 = over 9 = or over 10 = or over 13 = or over 44 = or swap drop if 2drop 2drop true exit then then begin swap dup c@ dup 32 = over 9 = or over 10 = or over 13 = or over 44 = or swap drop if false else true then 2 pick 0> and while 1+ swap 1- repeat swap repeat 2drop 2drop false ; : boot_serial? ( -- 0 | -1 ) s" console" getenv dup -1 <> if s" comconsole" 2swap contains? else drop false then s" boot_serial" getenv dup -1 <> if swap drop 0> else drop false then or \ console contains comconsole ( or ) boot_serial s" boot_multicons" getenv dup -1 <> if swap drop 0> else drop false then or \ previous boolean ( or ) boot_multicons ; \ Private definitions vocabulary support-functions only forth also support-functions definitions \ Some control characters constants 7 constant bell 8 constant backspace 9 constant tab 10 constant lf 13 constant \ Read buffer size 80 constant read_buffer_size \ Standard suffixes : load_module_suffix s" _load" ; : module_loadname_suffix s" _name" ; : module_type_suffix s" _type" ; : module_args_suffix s" _flags" ; : module_beforeload_suffix s" _before" ; : module_afterload_suffix s" _after" ; : module_loaderror_suffix s" _error" ; \ Support operators : >= < 0= ; : <= > 0= ; \ Assorted support functions : free-memory free if EFREE throw then ; : strget { var -- addr len } var .addr @ var .len @ ; \ assign addr len to variable. : strset { addr len var -- } addr var .addr ! len var .len ! ; \ free memory and reset fields : strfree { var -- } var .addr @ ?dup if free-memory 0 0 var strset then ; \ free old content, make a copy of the string and assign to variable : string= { addr len var -- } var strfree addr len strdup var strset ; : strtype ( str -- ) strget type ; \ assign a reference to what is on the stack : strref { addr len var -- addr len } addr var .addr ! len var .len ! addr len ; \ unquote a string : unquote ( addr len -- addr len ) over c@ [char] " = if 2 chars - swap char+ swap then ; \ Assignment data temporary storage string name_buffer string value_buffer \ Line by line file reading functions \ \ exported: \ line_buffer \ end_of_file? \ fd \ read_line \ reset_line_reading vocabulary line-reading -also line-reading definitions also +also line-reading definitions \ File data temporary storage string read_buffer 0 value read_buffer_ptr \ File's line reading function -support-functions definitions +get-current ( -- wid ) previous definitions string line_buffer 0 value end_of_file? variable fd -line-reading definitions +>search ( wid -- ) definitions : skip_newlines begin read_buffer .len @ read_buffer_ptr > while read_buffer .addr @ read_buffer_ptr + c@ lf = if read_buffer_ptr char+ to read_buffer_ptr else exit then repeat ; : scan_buffer ( -- addr len ) read_buffer_ptr >r begin read_buffer .len @ r@ > while read_buffer .addr @ r@ + c@ lf = if read_buffer .addr @ read_buffer_ptr + ( -- addr ) r@ read_buffer_ptr - ( -- len ) r> to read_buffer_ptr exit then r> char+ >r repeat read_buffer .addr @ read_buffer_ptr + ( -- addr ) r@ read_buffer_ptr - ( -- len ) r> to read_buffer_ptr ; : line_buffer_resize ( len -- len ) >r line_buffer .len @ if line_buffer .addr @ line_buffer .len @ r@ + resize if ENOMEM throw then else r@ allocate if ENOMEM throw then then line_buffer .addr ! r> ; : append_to_line_buffer ( addr len -- ) line_buffer strget 2swap strcat line_buffer .len ! drop ; : read_from_buffer scan_buffer ( -- addr len ) line_buffer_resize ( len -- len ) append_to_line_buffer ( addr len -- ) ; : refill_required? read_buffer .len @ read_buffer_ptr = end_of_file? 0= and ; : refill_buffer 0 to read_buffer_ptr read_buffer .addr @ 0= if read_buffer_size allocate if ENOMEM throw then read_buffer .addr ! then fd @ read_buffer .addr @ read_buffer_size fread dup -1 = if EREAD throw then dup 0= if true to end_of_file? then read_buffer .len ! ; -support-functions definitions +get-current ( -- wid ) previous definitions >search ( wid -- ) : reset_line_reading 0 to read_buffer_ptr ; : read_line line_buffer strfree skip_newlines begin read_from_buffer refill_required? while refill_buffer repeat ; only forth also support-functions definitions \ Conf file line parser: \ ::= '='[] | \ [] \ ::= {||'_'} \ ::= '"'{|'\'}'"' | \ ::= ASCII 32 to 126, except '\' and '"' \ ::= '#'{} \ \ exported: \ line_pointer \ process_conf 0 value line_pointer vocabulary file-processing also file-processing definitions \ parser functions \ \ exported: \ get_assignment vocabulary parser -also parser definitions also +also parser definitions 0 value parsing_function 0 value end_of_line : end_of_line? line_pointer end_of_line = ; \ classifiers for various character classes in the input line : letter? line_pointer c@ >r r@ [char] A >= r@ [char] Z <= and r@ [char] a >= r> [char] z <= and or ; : digit? line_pointer c@ >r r@ [char] - = r@ [char] 0 >= r> [char] 9 <= and or ; : quote? line_pointer c@ [char] " = ; : assignment_sign? line_pointer c@ [char] = = ; : comment? line_pointer c@ [char] # = ; : space? line_pointer c@ bl = line_pointer c@ tab = or ; : backslash? line_pointer c@ [char] \ = ; : underscore? line_pointer c@ [char] _ = ; : dot? line_pointer c@ [char] . = ; \ manipulation of input line : skip_character line_pointer char+ to line_pointer ; : skip_to_end_of_line end_of_line to line_pointer ; : eat_space begin end_of_line? if 0 else space? then while skip_character repeat ; : parse_name ( -- addr len ) line_pointer begin end_of_line? if 0 else letter? digit? underscore? dot? or or or then while skip_character repeat line_pointer over - strdup ; : remove_backslashes { addr len | addr' len' -- addr' len' } len allocate if ENOMEM throw then to addr' addr >r begin addr c@ [char] \ <> if addr c@ addr' len' + c! len' char+ to len' then addr char+ to addr r@ len + addr = until r> drop addr' len' ; : parse_quote ( -- addr len ) line_pointer skip_character end_of_line? if ESYNTAX throw then begin quote? 0= while backslash? if skip_character end_of_line? if ESYNTAX throw then then skip_character end_of_line? if ESYNTAX throw then repeat skip_character line_pointer over - remove_backslashes ; : read_name parse_name ( -- addr len ) name_buffer strset ; : read_value quote? if parse_quote ( -- addr len ) else parse_name ( -- addr len ) then value_buffer strset ; : comment skip_to_end_of_line ; : white_space_4 eat_space comment? if ['] comment to parsing_function exit then end_of_line? 0= if ESYNTAX throw then ; : variable_value read_value ['] white_space_4 to parsing_function ; : white_space_3 eat_space letter? digit? quote? or or if ['] variable_value to parsing_function exit then ESYNTAX throw ; : assignment_sign skip_character ['] white_space_3 to parsing_function ; : white_space_2 eat_space assignment_sign? if ['] assignment_sign to parsing_function exit then ESYNTAX throw ; : variable_name read_name ['] white_space_2 to parsing_function ; : white_space_1 eat_space letter? if ['] variable_name to parsing_function exit then comment? if ['] comment to parsing_function exit then end_of_line? 0= if ESYNTAX throw then ; -file-processing definitions +get-current ( -- wid ) previous definitions >search ( wid -- ) : get_assignment line_buffer strget + to end_of_line line_buffer .addr @ to line_pointer ['] white_space_1 to parsing_function begin end_of_line? 0= while parsing_function execute repeat parsing_function ['] comment = parsing_function ['] white_space_1 = parsing_function ['] white_space_4 = or or 0= if ESYNTAX throw then ; -only forth also support-functions also file-processing definitions also +only forth also support-functions also file-processing definitions \ Process line : assignment_type? ( addr len -- flag ) name_buffer strget compare 0= ; : suffix_type? ( addr len -- flag ) name_buffer .len @ over <= if 2drop false exit then name_buffer .len @ over - name_buffer .addr @ + over compare 0= ; : loader_conf_files? s" loader_conf_files" assignment_type? ; : nextboot_flag? s" nextboot_enable" assignment_type? ; : nextboot_conf? s" nextboot_conf" assignment_type? ; : verbose_flag? s" verbose_loading" assignment_type? ; : execute? s" exec" assignment_type? ; : module_load? load_module_suffix suffix_type? ; : module_loadname? module_loadname_suffix suffix_type? ; : module_type? module_type_suffix suffix_type? ; : module_args? module_args_suffix suffix_type? ; : module_beforeload? module_beforeload_suffix suffix_type? ; : module_afterload? module_afterload_suffix suffix_type? ; : module_loaderror? module_loaderror_suffix suffix_type? ; \ build a 'set' statement and execute it : set_environment_variable name_buffer .len @ value_buffer .len @ + 5 chars + \ size of result string allocate if ENOMEM throw then dup 0 \ start with an empty string and append the pieces s" set " strcat name_buffer strget strcat s" =" strcat value_buffer strget strcat ['] evaluate catch if 2drop free drop ESETERROR throw else free-memory then ; : set_conf_files set_environment_variable s" loader_conf_files" getenv conf_files string= ; : set_nextboot_conf \ XXX maybe do as set_conf_files ? value_buffer strget unquote nextboot_conf_file string= ; : append_to_module_options_list ( addr -- ) module_options @ 0= if dup module_options ! last_module_option ! else dup last_module_option @ module.next ! last_module_option ! then ; : set_module_name { addr -- } \ check leaks name_buffer strget addr module.name string= ; : yes_value? value_buffer strget \ XXX could use unquote 2dup s' "YES"' compare >r 2dup s' "yes"' compare >r 2dup s" YES" compare >r s" yes" compare r> r> r> and and and 0= ; : find_module_option ( -- addr | 0 ) \ return ptr to entry matching name_buffer module_options @ begin dup while dup module.name strget name_buffer strget compare 0= if exit then module.next @ repeat ; : new_module_option ( -- addr ) sizeof module allocate if ENOMEM throw then dup sizeof module erase dup append_to_module_options_list dup set_module_name ; : get_module_option ( -- addr ) find_module_option ?dup 0= if new_module_option then ; : set_module_flag name_buffer .len @ load_module_suffix nip - name_buffer .len ! yes_value? get_module_option module.flag ! ; : set_module_args name_buffer .len @ module_args_suffix nip - name_buffer .len ! value_buffer strget unquote get_module_option module.args string= ; : set_module_loadname name_buffer .len @ module_loadname_suffix nip - name_buffer .len ! value_buffer strget unquote get_module_option module.loadname string= ; : set_module_type name_buffer .len @ module_type_suffix nip - name_buffer .len ! value_buffer strget unquote get_module_option module.type string= ; : set_module_beforeload name_buffer .len @ module_beforeload_suffix nip - name_buffer .len ! value_buffer strget unquote get_module_option module.beforeload string= ; : set_module_afterload name_buffer .len @ module_afterload_suffix nip - name_buffer .len ! value_buffer strget unquote get_module_option module.afterload string= ; : set_module_loaderror name_buffer .len @ module_loaderror_suffix nip - name_buffer .len ! value_buffer strget unquote get_module_option module.loaderror string= ; : set_nextboot_flag yes_value? to nextboot? ; : set_verbose yes_value? to verbose? ; : execute_command value_buffer strget unquote ['] evaluate catch if EEXEC throw then ; : process_assignment name_buffer .len @ 0= if exit then loader_conf_files? if set_conf_files exit then nextboot_flag? if set_nextboot_flag exit then nextboot_conf? if set_nextboot_conf exit then verbose_flag? if set_verbose exit then execute? if execute_command exit then module_load? if set_module_flag exit then module_loadname? if set_module_loadname exit then module_type? if set_module_type exit then module_args? if set_module_args exit then module_beforeload? if set_module_beforeload exit then module_afterload? if set_module_afterload exit then module_loaderror? if set_module_loaderror exit then set_environment_variable ; \ free_buffer ( -- ) \ \ Free some pointers if needed. The code then tests for errors \ in freeing, and throws an exception if needed. If a pointer is \ not allocated, it's value (0) is used as flag. : free_buffers name_buffer strfree value_buffer strfree ; \ Higher level file processing -support-functions definitions +get-current ( -- wid ) previous definitions >search ( wid -- ) : process_conf begin end_of_file? 0= while free_buffers read_line get_assignment ['] process_assignment catch ['] free_buffers catch swap throw throw repeat ; : peek_file 0 to end_of_file? reset_line_reading O_RDONLY fopen fd ! fd @ -1 = if EOPEN throw then free_buffers read_line get_assignment ['] process_assignment catch ['] free_buffers catch fd @ fclose ; only forth also support-functions definitions \ Interface to loading conf files : load_conf ( addr len -- ) \ ." ----- Trying conf " 2dup type cr \ debugging 0 to end_of_file? reset_line_reading O_RDONLY fopen fd ! fd @ -1 = if EOPEN throw then ['] process_conf catch fd @ fclose throw ; : print_line line_buffer strtype cr ; : print_syntax_error line_buffer strtype cr line_buffer .addr @ begin line_pointer over <> while bl emit char+ repeat drop ." ^" cr ; \ Debugging support functions only forth definitions also support-functions : test-file ['] load_conf catch dup . ESYNTAX = if cr print_syntax_error then ; \ find a module name, leave addr on the stack (0 if not found) : find-module ( -- ptr | 0 ) bl parse ( addr len ) module_options @ >r ( store current pointer ) begin r@ while 2dup ( addr len addr len ) r@ module.name strget compare 0= if drop drop r> exit then ( found it ) r> module.next @ >r repeat type ." was not found" cr r> ; : show-nonempty ( addr len mod -- ) strget dup verbose? or if 2swap type type cr else drop drop drop drop then ; : show-one-module { addr -- addr } ." Name: " addr module.name strtype cr s" Path: " addr module.loadname show-nonempty s" Type: " addr module.type show-nonempty s" Flags: " addr module.args show-nonempty s" Before load: " addr module.beforeload show-nonempty s" After load: " addr module.afterload show-nonempty s" Error: " addr module.loaderror show-nonempty ." Status: " addr module.flag @ if ." Load" else ." Don't load" then cr cr addr ; : show-module-options module_options @ begin ?dup while show-one-module module.next @ repeat ; only forth also support-functions definitions \ Variables used for processing multiple conf files string current_file_name_ref \ used to print the file name \ Indicates if any conf file was succesfully read 0 value any_conf_read? \ loader_conf_files processing support functions : get_conf_files ( -- addr len ) \ put addr/len on stack, reset var \ ." -- starting on <" conf_files strtype ." >" cr \ debugging conf_files strget 0 0 conf_files strset ; : skip_leading_spaces { addr len pos -- addr len pos' } begin pos len = if 0 else addr pos + c@ bl = then while pos char+ to pos repeat addr len pos ; \ return the file name at pos, or free the string if nothing left : get_file_name { addr len pos -- addr len pos' addr' len' || 0 } pos len = if addr free abort" Fatal error freeing memory" 0 exit then pos >r begin \ stay in the loop until have chars and they are not blank pos len = if 0 else addr pos + c@ bl <> then while pos char+ to pos repeat addr len pos addr r@ + pos r> - \ 2dup ." get_file_name has " type cr \ debugging ; : get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) skip_leading_spaces get_file_name ; : print_current_file current_file_name_ref strtype ; : process_conf_errors dup 0= if true to any_conf_read? drop exit then >r 2drop r> dup ESYNTAX = if ." Warning: syntax error on file " print_current_file cr print_syntax_error drop exit then dup ESETERROR = if ." Warning: bad definition on file " print_current_file cr print_line drop exit then dup EREAD = if ." Warning: error reading file " print_current_file cr drop exit then dup EOPEN = if verbose? if ." Warning: unable to open file " print_current_file cr then drop exit then dup EFREE = abort" Fatal error freeing memory" dup ENOMEM = abort" Out of memory" throw \ Unknown error -- pass ahead ; \ Process loader_conf_files recursively \ Interface to loader_conf_files processing : include_conf_files get_conf_files 0 ( addr len offset ) begin get_next_file ?dup ( addr len 1 | 0 ) while current_file_name_ref strref ['] load_conf catch process_conf_errors conf_files .addr @ if recurse then repeat ; : get_nextboot_conf_file ( -- addr len ) nextboot_conf_file strget strdup \ XXX is the strdup a leak ? ; : rewrite_nextboot_file ( -- ) get_nextboot_conf_file O_WRONLY fopen fd ! fd @ -1 = if EOPEN throw then fd @ s' nextboot_enable="NO" ' fwrite fd @ fclose ; : include_nextboot_file get_nextboot_conf_file ['] peek_file catch nextboot? if get_nextboot_conf_file ['] load_conf catch process_conf_errors ['] rewrite_nextboot_file catch then ; \ Module loading functions : load_parameters { addr -- addr addrN lenN ... addr1 len1 N } addr addr module.args strget addr module.loadname .len @ if addr module.loadname strget else addr module.name strget then addr module.type .len @ if addr module.type strget s" -t " 4 ( -t type name flags ) else 2 ( name flags ) then ; : before_load ( addr -- addr ) dup module.beforeload .len @ if dup module.beforeload strget ['] evaluate catch if EBEFORELOAD throw then then ; : after_load ( addr -- addr ) dup module.afterload .len @ if dup module.afterload strget ['] evaluate catch if EAFTERLOAD throw then then ; : load_error ( addr -- addr ) dup module.loaderror .len @ if dup module.loaderror strget evaluate \ This we do not intercept so it can throw errors then ; : pre_load_message ( addr -- addr ) verbose? if dup module.name strtype ." ..." then ; : load_error_message verbose? if ." failed!" cr then ; : load_succesful_message verbose? if ." ok" cr then ; : load_module load_parameters load ; : process_module ( addr -- addr ) pre_load_message before_load begin ['] load_module catch if dup module.loaderror .len @ if load_error \ Command should return a flag! else load_error_message true \ Do not retry then else after_load load_succesful_message true \ Succesful, do not retry then until ; : process_module_errors ( addr ior -- ) dup EBEFORELOAD = if drop ." Module " dup module.name strtype dup module.loadname .len @ if ." (" dup module.loadname strtype ." )" then cr ." Error executing " dup module.beforeload strtype cr \ XXX there was a typo here abort then dup EAFTERLOAD = if drop ." Module " dup module.name .addr @ over module.name .len @ type dup module.loadname .len @ if ." (" dup module.loadname strtype ." )" then cr ." Error executing " dup module.afterload strtype cr abort then throw \ Don't know what it is all about -- pass ahead ; \ Module loading interface \ scan the list of modules, load enabled ones. : load_modules ( -- ) ( throws: abort & user-defined ) module_options @ ( list_head ) begin ?dup while dup module.flag @ if ['] process_module catch process_module_errors then module.next @ repeat ; \ h00h00 magic used to try loading either a kernel with a given name, \ or a kernel with the default name in a directory of a given name \ (the pain!) : bootpath s" /boot/" ; : modulepath s" module_path" ; \ Functions used to save and restore module_path's value. : saveenv ( addr len | -1 -- addr' len | 0 -1 ) dup -1 = if 0 swap exit then strdup ; : freeenv ( addr len | 0 -1 ) -1 = if drop else free abort" Freeing error" then ; : restoreenv ( addr len | 0 -1 -- ) dup -1 = if ( it wasn't set ) 2drop modulepath unsetenv else over >r modulepath setenv r> free abort" Freeing error" then ; : clip_args \ Drop second string if only one argument is passed 1 = if 2swap 2drop 1 else 2 then ; also builtins \ Parse filename from a semicolon-separated list \ replacement, not working yet : newparse-; { addr len | a1 -- a' len-x addr x } addr len [char] ; strchr dup if ( a1 len1 ) swap to a1 ( store address ) 1 - a1 @ 1 + swap ( remove match ) addr a1 addr - else 0 0 addr len then ; : parse-; ( addr len -- addr' len-x addr x ) over 0 2swap ( addr 0 addr len ) begin dup 0 <> ( addr 0 addr len ) while over c@ [char] ; <> ( addr 0 addr len flag ) while 1- swap 1+ swap 2swap 1+ 2swap repeat then dup 0 <> if 1- swap 1+ swap then 2swap ; \ Try loading one of multiple kernels specified : try_multiple_kernels ( addr len addr' len' args -- flag ) >r begin parse-; 2>r 2over 2r> r@ clip_args s" DEBUG" getenv? if s" echo Module_path: ${module_path}" evaluate ." Kernel : " >r 2dup type r> cr dup 2 = if ." Flags : " >r 2over type r> cr then then 1 load while dup 0= until 1 >r \ Failure else 0 >r \ Success then 2drop 2drop r> r> drop ; \ Try to load a kernel; the kernel name is taken from one of \ the following lists, as ordered: \ \ 1. The "bootfile" environment variable \ 2. The "kernel" environment variable \ \ Flags are passed, if available. If not, dummy values must be given. \ \ The kernel gets loaded from the current module_path. : load_a_kernel ( flags len 1 | x x 0 -- flag ) local args 2local flags 0 0 2local kernel end-locals \ Check if a default kernel name exists at all, exits if not s" bootfile" getenv dup -1 <> if to kernel flags kernel args 1+ try_multiple_kernels dup 0= if exit then then drop s" kernel" getenv dup -1 <> if to kernel else drop 1 exit \ Failure then \ Try all default kernel names flags kernel args 1+ try_multiple_kernels ; \ Try to load a kernel; the kernel name is taken from one of \ the following lists, as ordered: \ \ 1. The "bootfile" environment variable \ 2. The "kernel" environment variable \ \ Flags are passed, if provided. \ \ The kernel will be loaded from a directory computed from the \ path given. Two directories will be tried in the following order: \ \ 1. /boot/path \ 2. path \ \ The module_path variable is overridden if load is succesful, by \ prepending the successful path. : load_from_directory ( path len 1 | flags len' path len 2 -- flag ) local args 2local path args 1 = if 0 0 then 2local flags 0 0 2local oldmodulepath \ like a string 0 0 2local newmodulepath \ like a string end-locals \ Set the environment variable module_path, and try loading \ the kernel again. modulepath getenv saveenv to oldmodulepath \ Try prepending /boot/ first bootpath nip path nip + \ total length oldmodulepath nip dup -1 = if drop else 1+ + \ add oldpath -- XXX why the 1+ ? then allocate if ( out of memory ) 1 exit then \ XXX throw ? 0 bootpath strcat path strcat 2dup to newmodulepath modulepath setenv \ Try all default kernel names flags args 1- load_a_kernel 0= if ( success ) oldmodulepath nip -1 <> if newmodulepath s" ;" strcat oldmodulepath strcat modulepath setenv newmodulepath drop free-memory oldmodulepath drop free-memory then 0 exit then \ Well, try without the prepended /boot/ path newmodulepath drop swap move newmodulepath drop path nip 2dup to newmodulepath modulepath setenv \ Try all default kernel names flags args 1- load_a_kernel if ( failed once more ) oldmodulepath restoreenv newmodulepath drop free-memory 1 else oldmodulepath nip -1 <> if newmodulepath s" ;" strcat oldmodulepath strcat modulepath setenv newmodulepath drop free-memory oldmodulepath drop free-memory then 0 then ; \ Try to load a kernel; the kernel name is taken from one of \ the following lists, as ordered: \ \ 1. The "bootfile" environment variable \ 2. The "kernel" environment variable \ 3. The "path" argument \ \ Flags are passed, if provided. \ \ The kernel will be loaded from a directory computed from the \ path given. Two directories will be tried in the following order: \ \ 1. /boot/path \ 2. path \ \ Unless "path" is meant to be kernel name itself. In that case, it \ will first be tried as a full path, and, next, search on the \ directories pointed by module_path. \ \ The module_path variable is overridden if load is succesful, by \ prepending the successful path. : load_directory_or_file ( path len 1 | flags len' path len 2 -- flag ) local args 2local path args 1 = if 0 0 then 2local flags end-locals \ First, assume path is an absolute path to a directory flags path args clip_args load_from_directory dup 0= if exit else drop then \ Next, assume path points to the kernel flags path args try_multiple_kernels ; : initialize ( addr len -- ) strdup conf_files strset ; : kernel_options ( -- addr len 1 | 0 ) s" kernel_options" getenv dup -1 = if drop 0 else 1 then ; : standard_kernel_search ( flags 1 | 0 -- flag ) local args args 0= if 0 0 then 2local flags s" kernel" getenv dup -1 = if 0 swap then 2local path end-locals path nip -1 = if ( there isn't a "kernel" environment variable ) flags args load_a_kernel else flags path args 1+ clip_args load_directory_or_file then ; : load_kernel ( -- ) ( throws: abort ) kernel_options standard_kernel_search abort" Unable to load a kernel!" ; : load_xen ( -- ) s" xen_kernel" getenv dup -1 <> if 1 1 load else drop 0 then ; : load_xen_throw ( -- ) ( throws: abort ) load_xen abort" Unable to load Xen!" ; : set_defaultoptions ( -- ) s" kernel_options" getenv dup -1 = if drop else s" temp_options" setenv then ; \ pick the i-th argument, i starts at 0 : argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 ) 2dup = if 0 0 exit then \ out of range dup >r 1+ 2* ( skip N and ui ) pick r> 1+ 2* ( skip N and ai ) pick ; : drop_args ( aN uN ... a1 u1 N -- ) 0 ?do 2drop loop ; : argc dup ; : queue_argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 ) >r over 2* 1+ -roll r> over 2* 1+ -roll 1+ ; : unqueue_argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 ) 1- -rot ; \ compute the length of the buffer including the spaces between words : strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len ) dup 0= if 0 exit then 0 >r \ Size 0 >r \ Index begin argc r@ <> while r@ argv[] nip r> r> rot + 1+ >r 1+ >r repeat r> drop r> ; : concat_argv ( aN uN ... a1 u1 N -- a u ) strlen(argv) allocate if ENOMEM throw then 0 2>r ( save addr 0 on return stack ) begin dup while unqueue_argv ( ... N a1 u1 ) 2r> 2swap ( old a1 u1 ) strcat s" " strcat ( append one space ) \ XXX this gives a trailing space 2>r ( store string on the result stack ) repeat drop_args 2r> ; : set_tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 ) \ Save the first argument, if it exists and is not a flag argc if 0 argv[] drop c@ [char] - <> if unqueue_argv 2>r \ Filename 1 >r \ Filename present else 0 >r \ Filename not present then else 0 >r \ Filename not present then \ If there are other arguments, assume they are flags ?dup if concat_argv 2dup s" temp_options" setenv drop free if EFREE throw then else set_defaultoptions then \ Bring back the filename, if one was provided r> if 2r> 1 else 0 then ; : get_arguments ( -- addrN lenN ... addr1 len1 N ) 0 begin \ Get next word on the command line parse-word ?dup while queue_argv repeat drop ( empty string ) ; : load_kernel_and_modules ( args -- flag ) set_tempoptions argc >r s" temp_options" getenv dup -1 <> if queue_argv else drop then load_xen ?dup 0= if ( success ) r> if ( a path was passed ) load_directory_or_file else standard_kernel_search then ?dup 0= if ['] load_modules catch then then ; -\ Go back to straight forth vocabulary - -only forth also definitions - +only forth definitions Index: head/sys/boot/forth/version.4th =================================================================== --- head/sys/boot/forth/version.4th (revision 280936) +++ head/sys/boot/forth/version.4th (revision 280937) @@ -1,88 +1,95 @@ \ Copyright (c) 2006-2015 Devin Teske \ All rights reserved. \ \ Redistribution and use in source and binary forms, with or without \ modification, are permitted provided that the following conditions \ are met: \ 1. Redistributions of source code must retain the above copyright \ notice, this list of conditions and the following disclaimer. \ 2. Redistributions in binary form must reproduce the above copyright \ notice, this list of conditions and the following disclaimer in the \ documentation and/or other materials provided with the distribution. \ \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF \ SUCH DAMAGE. \ \ $FreeBSD$ marker task-version.4th +vocabulary version-processing +only forth also version-processing definitions + variable versionX variable versionY \ Default $loader_version value if not overridden or using tribute screen : str_loader_version ( -- C-ADDR/U|-1 ) -1 ; \ Initialize text placement to defaults 80 versionX ! \ NOTE: this is the ending column (text is right-justified) 24 versionY ! +only forth definitions also version-processing + : print_version ( -- ) \ Get the text placement position (if set) s" loader_version_x" getenv dup -1 <> if ?number drop versionX ! -1 then drop s" loader_version_y" getenv dup -1 <> if ?number drop versionY ! -1 then drop \ Default version if none was set s" loader_version" getenv dup -1 = if drop \ Use above default if no logo is requested s" loader_logo" getenv dup -1 = if drop str_loader_version else \ For tributes, do nothing (defer to logo-*.4th) 2dup s" tribute" compare-insensitive 0= if 2drop s" logo" sfind if drop exit \ see logo-tribute.4th else drop str_loader_version then else 2dup s" tributebw" compare-insensitive 0= if 2drop s" logo" sfind if drop exit \ see logo-tributebw.4th else drop str_loader_version then else 2drop str_loader_version then then then then dup -1 = if drop exit \ default version (above) is disabled then \ Right justify the text dup versionX @ swap - versionY @ at-xy \ Print the version (optionally in cyan) loader_color? if ." " type ." " else type then ; + +only forth definitions