1 \ Copyright (c) 2012 Devin Teske <dteske@FreeBSD.org>
4 \ Redistribution and use in source and binary forms, with or without
5 \ modification, are permitted provided that the following conditions
7 \ 1. Redistributions of source code must retain the above copyright
8 \ notice, this list of conditions and the following disclaimer.
9 \ 2. Redistributions in binary form must reproduce the above copyright
10 \ notice, this list of conditions and the following disclaimer in the
11 \ documentation and/or other materials provided with the distribution.
13 \ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
14 \ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
15 \ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
16 \ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
17 \ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
18 \ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
19 \ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
20 \ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
21 \ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
22 \ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
26 marker task-menusets.4th
28 vocabulary menusets-infrastructure
29 only forth also menusets-infrastructure definitions
31 variable menuset_use_name
33 create menuset_affixbuf 255 allot
34 create menuset_x 1 allot
35 create menuset_y 1 allot
37 : menuset-loadvar ( -- )
39 \ menuset_use_name is true or false
40 \ $type should be set to one of:
42 \ $var should be set to one of:
43 \ caption command keycode text ...
44 \ $affix is either prefix (menuset_use_name is true)
45 \ or infix (menuset_use_name is false)
47 s" set cmdbuf='set ${type}_${var}=\$'" evaluate
48 s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
49 menuset_use_name @ true = if
50 s" set cmdbuf=${cmdbuf}${affix}${type}_${var}"
51 ( u1 -- u1 c-addr2 u2 )
53 s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}"
54 ( u1 -- u1 c-addr2 u2 )
56 evaluate ( u1 c-addr2 u2 -- u1 )
57 s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
58 rot 2 pick 2 pick over + -rot + tuck -
59 ( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
60 \ Generate a string representing rvalue inheritance var
62 ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
63 \ NOT set -- clean up the stack
64 drop ( c-addr2 u2 -1 -- c-addr2 u2 )
65 2drop ( c-addr2 u2 -- )
67 ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
68 \ SET -- execute cmdbuf (c-addr2/u2) to inherit value
69 2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
70 evaluate ( c-addr2 u2 -- )
76 : menuset-unloadvar ( -- )
78 \ menuset_use_name is true or false
79 \ $type should be set to one of:
81 \ $var should be set to one of:
82 \ caption command keycode text ...
83 \ $affix is either prefix (menuset_use_name is true)
84 \ or infix (menuset_use_name is false)
86 menuset_use_name @ true = if
87 s" set buf=${affix}${type}_${var}"
89 s" set buf=${type}set${affix}_${var}"
92 s" buf" getenv unsetenv
96 : menuset-loadmenuvar ( -- )
97 s" set type=menu" evaluate
101 : menuset-unloadmenuvar ( -- )
102 s" set type=menu" evaluate
106 : menuset-loadxvar ( -- )
108 \ menuset_use_name is true or false
109 \ $type should be set to one of:
111 \ $var should be set to one of:
112 \ caption command keycode text ...
113 \ $x is "1" through "8"
114 \ $affix is either prefix (menuset_use_name is true)
115 \ or infix (menuset_use_name is false)
117 s" set cmdbuf='set ${type}_${var}[${x}]=\$'" evaluate
118 s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
119 menuset_use_name @ true = if
120 s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}]"
121 ( u1 -- u1 c-addr2 u2 )
123 s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}]"
124 ( u1 -- u1 c-addr2 u2 )
126 evaluate ( u1 c-addr2 u2 -- u1 )
127 s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
128 rot 2 pick 2 pick over + -rot + tuck -
129 ( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
130 \ Generate a string representing rvalue inheritance var
132 ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
133 \ NOT set -- clean up the stack
134 drop ( c-addr2 u2 -1 -- c-addr2 u2 )
135 2drop ( c-addr2 u2 -- )
137 ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
138 \ SET -- execute cmdbuf (c-addr2/u2) to inherit value
139 2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
140 evaluate ( c-addr2 u2 -- )
146 : menuset-unloadxvar ( -- )
148 \ menuset_use_name is true or false
149 \ $type should be set to one of:
151 \ $var should be set to one of:
152 \ caption command keycode text ...
153 \ $x is "1" through "8"
154 \ $affix is either prefix (menuset_use_name is true)
155 \ or infix (menuset_use_name is false)
157 menuset_use_name @ true = if
158 s" set buf=${affix}${type}_${var}[${x}]"
160 s" set buf=${type}set${affix}_${var}[${x}]"
163 s" buf" getenv unsetenv
167 : menuset-loadansixvar ( -- )
168 s" set type=ansi" evaluate
172 : menuset-unloadansixvar ( -- )
173 s" set type=ansi" evaluate
177 : menuset-loadmenuxvar ( -- )
178 s" set type=menu" evaluate
182 : menuset-unloadmenuxvar ( -- )
183 s" set type=menu" evaluate
187 : menuset-unloadtypelessxvar ( -- )
188 s" set type=" evaluate
192 : menuset-loadtoggledxvar ( -- )
193 s" set type=toggled" evaluate
197 : menuset-unloadtoggledxvar ( -- )
198 s" set type=toggled" evaluate
202 : menuset-loadxyvar ( -- )
204 \ menuset_use_name is true or false
205 \ $type should be set to one of:
207 \ $var should be set to one of:
208 \ caption command keycode text ...
209 \ $x is "1" through "8"
210 \ $y is "0" through "9"
211 \ $affix is either prefix (menuset_use_name is true)
212 \ or infix (menuset_use_name is false)
214 s" set cmdbuf='set ${type}_${var}[${x}][${y}]=\$'" evaluate
215 s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
216 menuset_use_name @ true = if
217 s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}][${y}]"
218 ( u1 -- u1 c-addr2 u2 )
220 s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}][${y}]"
221 ( u1 -- u1 c-addr2 u2 )
223 evaluate ( u1 c-addr2 u2 -- u1 )
224 s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
225 rot 2 pick 2 pick over + -rot + tuck -
226 ( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
227 \ Generate a string representing rvalue inheritance var
229 ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
230 \ NOT set -- clean up the stack
231 drop ( c-addr2 u2 -1 -- c-addr2 u2 )
232 2drop ( c-addr2 u2 -- )
234 ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
235 \ SET -- execute cmdbuf (c-addr2/u2) to inherit value
236 2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
237 evaluate ( c-addr2 u2 -- )
243 : menuset-unloadxyvar ( -- )
245 \ menuset_use_name is true or false
246 \ $type should be set to one of:
248 \ $var should be set to one of:
249 \ caption command keycode text ...
250 \ $x is "1" through "8"
251 \ $y is "0" through "9"
252 \ $affix is either prefix (menuset_use_name is true)
253 \ or infix (menuset_use_name is false)
255 menuset_use_name @ true = if
256 s" set buf=${affix}${type}_${var}[${x}][${y}]"
258 s" set buf=${type}set${affix}_${var}[${x}][${y}]"
261 s" buf" getenv unsetenv
265 : menuset-loadansixyvar ( -- )
266 s" set type=ansi" evaluate
270 : menuset-unloadansixyvar ( -- )
271 s" set type=ansi" evaluate
275 : menuset-loadmenuxyvar ( -- )
276 s" set type=menu" evaluate
280 : menuset-unloadmenuxyvar ( -- )
281 s" set type=menu" evaluate
285 : menuset-setnum-namevar ( N -- C-Addr/U )
287 s" menuset_nameNNNNN" ( n -- n c-addr1 u1 ) \ variable basename
288 drop 12 ( n c-addr1 u1 -- n c-addr1 12 ) \ remove "NNNNN"
289 rot ( n c-addr1 12 -- c-addr1 12 n ) \ move number on top
292 s>d <# #s #> ( c-addr1 12 n -- c-addr1 12 c-addr2 u2 )
295 begin ( using u2 in c-addr2/u2 pair as countdown to zero )
296 over ( c-addr1 u1 c-addr2 u2 -- continued below )
297 ( c-addr1 u1 c-addr2 u2 c-addr2 ) \ copy src-addr
298 c@ ( c-addr1 u1 c-addr2 u2 c-addr2 -- continued below )
299 ( c-addr1 u1 c-addr2 u2 c ) \ get next src-addr byte
301 ( c-addr1 u1 c-addr2 u2 c -- continued below )
302 ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
303 \ get destination c-addr1/u1 pair
304 + ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- cont. below )
305 ( c-addr1 u1 c-addr2 u2 c c-addr3 )
306 \ combine dest-c-addr to get dest-addr for byte
307 c! ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
308 ( c-addr1 u1 c-addr2 u2 )
309 \ store the current src-addr byte into dest-addr
311 2swap 1+ 2swap \ increment u1 in destination c-addr1/u1 pair
312 swap 1+ swap \ increment c-addr2 in source c-addr2/u2 pair
313 1- \ decrement u2 in the source c-addr2/u2 pair
315 dup 0= \ time to break?
318 2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 )
319 \ drop temporary number-format conversion c-addr2/u2
322 : menuset-checksetnum ( N -- )
325 \ adjust input to be both positive and no-higher than 65535
327 abs dup 65535 > if drop 65535 then ( n -- n )
330 \ The next few blocks will determine if we should use the default
331 \ methodology (referencing the original numeric stack-input), or if-
332 \ instead $menuset_name{N} has been defined wherein we would then
333 \ use the value thereof as the prefix to every menu variable.
336 false menuset_use_name ! \ assume name is not set
338 menuset-setnum-namevar
340 \ We now have a string that is the assembled variable name to check
341 \ for... $menuset_name{N}. Let's check for it.
343 2dup ( c-addr1 u1 -- c-addr1 u1 c-addr1 u1 ) \ save a copy
344 getenv dup -1 <> if ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 c-addr2 u2 )
345 \ The variable is set. Let's clean up the stack leaving only
346 \ its value for later use.
348 true menuset_use_name !
349 2swap 2drop ( c-addr1 u1 c-addr2 u2 -- c-addr2 u2 )
350 \ drop assembled variable name, leave the value
351 else ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 -1 ) \ no such variable
352 \ The variable is not set. Let's clean up the stack leaving the
353 \ string [portion] representing the original numeric input.
355 drop ( c-addr1 u1 -1 -- c-addr1 u1 ) \ drop -1 result
356 12 - swap 12 + swap ( c-addr1 u1 -- c-addr2 u2 )
357 \ truncate to original numeric stack-input
361 \ Now, depending on whether $menuset_name{N} has been set, we have
362 \ either the value thereof to be used as a prefix to all menu_*
363 \ variables or we have a string representing the numeric stack-input
364 \ to be used as a "set{N}" infix to the same menu_* variables.
366 \ For example, if the stack-input is 1 and menuset_name1 is NOT set
367 \ the following variables will be referenced:
368 \ ansiset1_caption[x] -> ansi_caption[x]
369 \ ansiset1_caption[x][y] -> ansi_caption[x][y]
370 \ menuset1_acpi -> menu_acpi
371 \ menuset1_osconsole -> menu_osconsole
372 \ menuset1_caption[x] -> menu_caption[x]
373 \ menuset1_caption[x][y] -> menu_caption[x][y]
374 \ menuset1_command[x] -> menu_command[x]
375 \ menuset1_init -> ``evaluated''
376 \ menuset1_init[x] -> menu_init[x]
377 \ menuset1_kernel -> menu_kernel
378 \ menuset1_keycode[x] -> menu_keycode[x]
379 \ menuset1_options -> menu_options
380 \ menuset1_optionstext -> menu_optionstext
381 \ menuset1_reboot -> menu_reboot
382 \ toggledset1_ansi[x] -> toggled_ansi[x]
383 \ toggledset1_text[x] -> toggled_text[x]
384 \ otherwise, the following variables are referenced (where {name}
385 \ represents the value of $menuset_name1 (given 1 as stack-input):
386 \ {name}ansi_caption[x] -> ansi_caption[x]
387 \ {name}ansi_caption[x][y] -> ansi_caption[x][y]
388 \ {name}menu_acpi -> menu_acpi
389 \ {name}menu_caption[x] -> menu_caption[x]
390 \ {name}menu_caption[x][y] -> menu_caption[x][y]
391 \ {name}menu_command[x] -> menu_command[x]
392 \ {name}menu_init -> ``evaluated''
393 \ {name}menu_init[x] -> menu_init[x]
394 \ {name}menu_kernel -> menu_kernel
395 \ {name}menu_keycode[x] -> menu_keycode[x]
396 \ {name}menu_options -> menu_options
397 \ {name}menu_optionstext -> menu_optionstext
398 \ {name}menu_reboot -> menu_reboot
399 \ {name}toggled_ansi[x] -> toggled_ansi[x]
400 \ {name}toggled_text[x] -> toggled_text[x]
402 \ Note that menuset{N}_init and {name}menu_init are the initializers
403 \ for the entire menu (for wholly dynamic menus) opposed to the per-
404 \ menuitem initializers (with [x] afterward). The whole-menu init
405 \ routine is evaluated and not passed down to $menu_init (which
406 \ would result in double evaluation). By doing this, the initializer
407 \ can initialize the menuset before we transfer it to active-duty.
411 \ Copy our affixation (prefix or infix depending on menuset_use_name)
412 \ to our buffer so that we can safely use the s-quote (s") buf again.
414 menuset_affixbuf 0 2swap ( c-addr2 u2 -- c-addr1 0 c-addr2 u2 )
415 begin ( using u2 in c-addr2/u2 pair as countdown to zero )
416 over ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c-addr2 )
417 c@ ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c )
419 ( c-addr1 u1 c-addr2 u2 c -- continued below )
420 ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
421 + ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- continued below )
422 ( c-addr1 u1 c-addr2 u2 c c-addr3 )
423 c! ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
424 ( c-addr1 u1 c-addr2 u2 )
425 2swap 1+ 2swap \ increment affixbuf byte position/count
426 swap 1+ swap \ increment strbuf pointer (source c-addr2)
427 1- \ decrement strbuf byte count (source u2)
428 dup 0= \ time to break?
430 2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 ) \ drop strbuf c-addr2/u2
433 \ Create a variable for referencing our affix data (prefix or infix
434 \ depending on menuset_use_name as described above). This variable will
435 \ be temporary and only used to simplify cmdbuf assembly.
437 s" affix" setenv ( c-addr1 u1 -- )
440 : menuset-cleanup ( -- )
448 only forth definitions also menusets-infrastructure
450 : menuset-loadsetnum ( N -- )
452 menuset-checksetnum ( n -- )
455 \ From here out, we use temporary environment variables to make
456 \ dealing with variable-length strings easier.
458 \ menuset_use_name is true or false
459 \ $affix should be used appropriately w/respect to menuset_use_name
463 s" set var=init" evaluate
466 \ If menu_init was set by the above, evaluate it here-and-now
467 \ so that the remaining variables are influenced by its actions
468 s" menu_init" 2dup getenv dup -1 <> if
469 2swap unsetenv \ don't want later menu-create to re-call this
472 drop 2drop ( n c-addr u -1 -- n )
475 [char] 1 ( -- x ) \ Loop range ASCII '1' (49) to '8' (56)
477 dup menuset_x tuck c! 1 s" x" setenv \ set loop iterator and $x
479 s" set var=caption" evaluate
481 \ ... menu_caption[x] ...
484 \ ... ansi_caption[x] ...
487 [char] 0 ( x -- x y ) \ Inner Loop ASCII '1' (48) to '9' (57)
489 dup menuset_y tuck c! 1 s" y" setenv
490 \ set inner loop iterator and $y
492 \ ... menu_caption[x][y] ...
493 menuset-loadmenuxyvar
495 \ ... ansi_caption[x][y] ...
496 menuset-loadansixyvar
498 1+ dup 57 > ( x y -- y' 0|-1 ) \ increment and test
502 \ ... menu_command[x] ...
503 s" set var=command" evaluate
506 \ ... menu_init[x] ...
507 s" set var=init" evaluate
510 \ ... menu_keycode[x] ...
511 s" set var=keycode" evaluate
514 \ ... toggled_text[x] ...
515 s" set var=text" evaluate
516 menuset-loadtoggledxvar
518 \ ... toggled_ansi[x] ...
519 s" set var=ansi" evaluate
520 menuset-loadtoggledxvar
522 1+ dup 56 > ( x -- x' 0|-1 ) \ increment iterator
523 \ continue if less than 57
525 drop ( x -- ) \ loop iterator
527 \ ... menu_reboot ...
528 s" set var=reboot" evaluate
532 s" set var=acpi" evaluate
535 \ ... menu_osconsole ...
536 s" set var=osconsole" evaluate
539 \ ... menu_kernel ...
540 s" set var=kernel" evaluate
543 \ ... menu_options ...
544 s" set var=options" evaluate
547 \ ... menu_optionstext ...
548 s" set var=optionstext" evaluate
554 : menusets-unset ( -- )
556 \ clean up BE menu internal variables
557 s" beansi_bootfs" unsetenv
558 s" beansi_current" unsetenv
559 s" beansi_page" unsetenv
560 s" beansi_pageof" unsetenv
561 s" bemenu_bootfs" unsetenv
562 s" bemenu_current" unsetenv
563 s" bemenu_page" unsetenv
564 s" bemenu_pageof" unsetenv
565 s" zfs_be_active" unsetenv
566 s" zfs_be_currpage" unsetenv
567 s" zfs_be_pages" unsetenv
569 s" menuset_initial" unsetenv
572 dup menuset-checksetnum ( n n -- n )
574 dup menuset-setnum-namevar ( n n -- n )
577 \ If the current menuset does not populate the first menuitem,
578 \ we stop completely.
580 menuset_use_name @ true = if
581 s" set buf=${affix}menu_command[1]"
583 s" set buf=menuset${affix}_command[1]"
585 evaluate s" buf" getenv getenv -1 = if
591 drop ( n c-addr2 -- n ) \ unused
594 [char] 1 ( n -- n x ) \ Loop range ASCII '1' (49) to '8' (56)
596 dup menuset_x tuck c! 1 s" x" setenv \ set $x to x
598 s" set var=caption" evaluate
599 menuset-unloadmenuxvar
600 menuset-unloadmenuxvar
601 menuset-unloadansixvar
602 [char] 0 ( n x -- n x y ) \ Inner loop '0' to '9'
604 dup menuset_y tuck c! 1 s" y" setenv
606 menuset-unloadmenuxyvar
607 menuset-unloadansixyvar
608 1+ dup 57 > ( n x y -- n x y' 0|-1 )
610 drop ( n x y -- n x )
611 s" set var=command" evaluate menuset-unloadmenuxvar
612 s" set var=init" evaluate menuset-unloadmenuxvar
613 s" set var=keycode" evaluate menuset-unloadmenuxvar
614 s" set var=root" evaluate menuset-unloadtypelessxvar
615 s" set var=text" evaluate menuset-unloadtoggledxvar
616 s" set var=ansi" evaluate menuset-unloadtoggledxvar
618 1+ dup 56 > ( x -- x' 0|-1 ) \ increment and test
620 drop ( n x -- n ) \ loop iterator
622 s" set var=acpi" evaluate menuset-unloadmenuvar
623 s" set var=osconsole" evaluate menuset-unloadmenuvar
624 s" set var=init" evaluate menuset-unloadmenuvar
625 s" set var=kernel" evaluate menuset-unloadmenuvar
626 s" set var=options" evaluate menuset-unloadmenuvar
627 s" set var=optionstext" evaluate menuset-unloadmenuvar
628 s" set var=reboot" evaluate menuset-unloadmenuvar
630 1+ dup 65535 > ( n -- n' 0|-1 ) \ increment and test
632 drop ( n' -- ) \ loop iterator
638 only forth definitions
640 : menuset-loadinitial ( -- )
641 s" menuset_initial" getenv dup -1 <> if