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
27 marker task-menusets.4th
29 vocabulary menusets-infrastructure
30 only forth also menusets-infrastructure definitions
32 variable menuset_use_name
34 create menuset_affixbuf 255 allot
35 create menuset_x 1 allot
36 create menuset_y 1 allot
38 : menuset-loadvar ( -- )
40 \ menuset_use_name is true or false
41 \ $type should be set to one of:
43 \ $var should be set to one of:
44 \ caption command keycode text ...
45 \ $affix is either prefix (menuset_use_name is true)
46 \ or infix (menuset_use_name is false)
48 s" set cmdbuf='set ${type}_${var}=\$'" evaluate
49 s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
50 menuset_use_name @ true = if
51 s" set cmdbuf=${cmdbuf}${affix}${type}_${var}"
52 ( u1 -- u1 c-addr2 u2 )
54 s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}"
55 ( u1 -- u1 c-addr2 u2 )
57 evaluate ( u1 c-addr2 u2 -- u1 )
58 s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
59 rot 2 pick 2 pick over + -rot + tuck -
60 ( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
61 \ Generate a string representing rvalue inheritance var
63 ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
64 \ NOT set -- clean up the stack
65 drop ( c-addr2 u2 -1 -- c-addr2 u2 )
66 2drop ( c-addr2 u2 -- )
68 ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
69 \ SET -- execute cmdbuf (c-addr2/u2) to inherit value
70 2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
71 evaluate ( c-addr2 u2 -- )
77 : menuset-unloadvar ( -- )
79 \ menuset_use_name is true or false
80 \ $type should be set to one of:
82 \ $var should be set to one of:
83 \ caption command keycode text ...
84 \ $affix is either prefix (menuset_use_name is true)
85 \ or infix (menuset_use_name is false)
87 menuset_use_name @ true = if
88 s" set buf=${affix}${type}_${var}"
90 s" set buf=${type}set${affix}_${var}"
93 s" buf" getenv unsetenv
97 : menuset-loadmenuvar ( -- )
98 s" set type=menu" evaluate
102 : menuset-unloadmenuvar ( -- )
103 s" set type=menu" evaluate
107 : menuset-loadxvar ( -- )
109 \ menuset_use_name is true or false
110 \ $type should be set to one of:
112 \ $var should be set to one of:
113 \ caption command keycode text ...
114 \ $x is "1" through "8"
115 \ $affix is either prefix (menuset_use_name is true)
116 \ or infix (menuset_use_name is false)
118 s" set cmdbuf='set ${type}_${var}[${x}]=\$'" evaluate
119 s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
120 menuset_use_name @ true = if
121 s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}]"
122 ( u1 -- u1 c-addr2 u2 )
124 s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}]"
125 ( u1 -- u1 c-addr2 u2 )
127 evaluate ( u1 c-addr2 u2 -- u1 )
128 s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
129 rot 2 pick 2 pick over + -rot + tuck -
130 ( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
131 \ Generate a string representing rvalue inheritance var
133 ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
134 \ NOT set -- clean up the stack
135 drop ( c-addr2 u2 -1 -- c-addr2 u2 )
136 2drop ( c-addr2 u2 -- )
138 ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
139 \ SET -- execute cmdbuf (c-addr2/u2) to inherit value
140 2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
141 evaluate ( c-addr2 u2 -- )
147 : menuset-unloadxvar ( -- )
149 \ menuset_use_name is true or false
150 \ $type should be set to one of:
152 \ $var should be set to one of:
153 \ caption command keycode text ...
154 \ $x is "1" through "8"
155 \ $affix is either prefix (menuset_use_name is true)
156 \ or infix (menuset_use_name is false)
158 menuset_use_name @ true = if
159 s" set buf=${affix}${type}_${var}[${x}]"
161 s" set buf=${type}set${affix}_${var}[${x}]"
164 s" buf" getenv unsetenv
168 : menuset-loadansixvar ( -- )
169 s" set type=ansi" evaluate
173 : menuset-unloadansixvar ( -- )
174 s" set type=ansi" evaluate
178 : menuset-loadmenuxvar ( -- )
179 s" set type=menu" evaluate
183 : menuset-unloadmenuxvar ( -- )
184 s" set type=menu" evaluate
188 : menuset-loadtoggledxvar ( -- )
189 s" set type=toggled" evaluate
193 : menuset-unloadtoggledxvar ( -- )
194 s" set type=toggled" evaluate
198 : menuset-loadxyvar ( -- )
200 \ menuset_use_name is true or false
201 \ $type should be set to one of:
203 \ $var should be set to one of:
204 \ caption command keycode text ...
205 \ $x is "1" through "8"
206 \ $y is "0" through "9"
207 \ $affix is either prefix (menuset_use_name is true)
208 \ or infix (menuset_use_name is false)
210 s" set cmdbuf='set ${type}_${var}[${x}][${y}]=\$'" evaluate
211 s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
212 menuset_use_name @ true = if
213 s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}][${y}]"
214 ( u1 -- u1 c-addr2 u2 )
216 s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}][${y}]"
217 ( u1 -- u1 c-addr2 u2 )
219 evaluate ( u1 c-addr2 u2 -- u1 )
220 s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
221 rot 2 pick 2 pick over + -rot + tuck -
222 ( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
223 \ Generate a string representing rvalue inheritance var
225 ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
226 \ NOT set -- clean up the stack
227 drop ( c-addr2 u2 -1 -- c-addr2 u2 )
228 2drop ( c-addr2 u2 -- )
230 ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
231 \ SET -- execute cmdbuf (c-addr2/u2) to inherit value
232 2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
233 evaluate ( c-addr2 u2 -- )
239 : menuset-unloadxyvar ( -- )
241 \ menuset_use_name is true or false
242 \ $type should be set to one of:
244 \ $var should be set to one of:
245 \ caption command keycode text ...
246 \ $x is "1" through "8"
247 \ $y is "0" through "9"
248 \ $affix is either prefix (menuset_use_name is true)
249 \ or infix (menuset_use_name is false)
251 menuset_use_name @ true = if
252 s" set buf=${affix}${type}_${var}[${x}][${y}]"
254 s" set buf=${type}set${affix}_${var}[${x}][${y}]"
257 s" buf" getenv unsetenv
261 : menuset-loadansixyvar ( -- )
262 s" set type=ansi" evaluate
266 : menuset-unloadansixyvar ( -- )
267 s" set type=ansi" evaluate
271 : menuset-loadmenuxyvar ( -- )
272 s" set type=menu" evaluate
276 : menuset-unloadmenuxyvar ( -- )
277 s" set type=menu" evaluate
281 : menuset-setnum-namevar ( N -- C-Addr/U )
283 s" menuset_nameNNNNN" ( n -- n c-addr1 u1 ) \ variable basename
284 drop 12 ( n c-addr1 u1 -- n c-addr1 12 ) \ remove "NNNNN"
285 rot ( n c-addr1 12 -- c-addr1 12 n ) \ move number on top
288 s>d <# #s #> ( c-addr1 12 n -- c-addr1 12 c-addr2 u2 )
291 begin ( using u2 in c-addr2/u2 pair as countdown to zero )
292 over ( c-addr1 u1 c-addr2 u2 -- continued below )
293 ( c-addr1 u1 c-addr2 u2 c-addr2 ) \ copy src-addr
294 c@ ( c-addr1 u1 c-addr2 u2 c-addr2 -- continued below )
295 ( c-addr1 u1 c-addr2 u2 c ) \ get next src-addr byte
297 ( c-addr1 u1 c-addr2 u2 c -- continued below )
298 ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
299 \ get destination c-addr1/u1 pair
300 + ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- cont. below )
301 ( c-addr1 u1 c-addr2 u2 c c-addr3 )
302 \ combine dest-c-addr to get dest-addr for byte
303 c! ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
304 ( c-addr1 u1 c-addr2 u2 )
305 \ store the current src-addr byte into dest-addr
307 2swap 1+ 2swap \ increment u1 in destination c-addr1/u1 pair
308 swap 1+ swap \ increment c-addr2 in source c-addr2/u2 pair
309 1- \ decrement u2 in the source c-addr2/u2 pair
311 dup 0= \ time to break?
314 2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 )
315 \ drop temporary number-format conversion c-addr2/u2
318 : menuset-checksetnum ( N -- )
321 \ adjust input to be both positive and no-higher than 65535
323 abs dup 65535 > if drop 65535 then ( n -- n )
326 \ The next few blocks will determine if we should use the default
327 \ methodology (referencing the original numeric stack-input), or if-
328 \ instead $menuset_name{N} has been defined wherein we would then
329 \ use the value thereof as the prefix to every menu variable.
332 false menuset_use_name ! \ assume name is not set
334 menuset-setnum-namevar
336 \ We now have a string that is the assembled variable name to check
337 \ for... $menuset_name{N}. Let's check for it.
339 2dup ( c-addr1 u1 -- c-addr1 u1 c-addr1 u1 ) \ save a copy
340 getenv dup -1 <> if ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 c-addr2 u2 )
341 \ The variable is set. Let's clean up the stack leaving only
342 \ its value for later use.
344 true menuset_use_name !
345 2swap 2drop ( c-addr1 u1 c-addr2 u2 -- c-addr2 u2 )
346 \ drop assembled variable name, leave the value
347 else ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 -1 ) \ no such variable
348 \ The variable is not set. Let's clean up the stack leaving the
349 \ string [portion] representing the original numeric input.
351 drop ( c-addr1 u1 -1 -- c-addr1 u1 ) \ drop -1 result
352 12 - swap 12 + swap ( c-addr1 u1 -- c-addr2 u2 )
353 \ truncate to original numeric stack-input
357 \ Now, depending on whether $menuset_name{N} has been set, we have
358 \ either the value thereof to be used as a prefix to all menu_*
359 \ variables or we have a string representing the numeric stack-input
360 \ to be used as a "set{N}" infix to the same menu_* variables.
362 \ For example, if the stack-input is 1 and menuset_name1 is NOT set
363 \ the following variables will be referenced:
364 \ ansiset1_caption[x] -> ansi_caption[x]
365 \ ansiset1_caption[x][y] -> ansi_caption[x][y]
366 \ menuset1_acpi -> menu_acpi
367 \ menuset1_caption[x] -> menu_caption[x]
368 \ menuset1_caption[x][y] -> menu_caption[x][y]
369 \ menuset1_command[x] -> menu_command[x]
370 \ menuset1_init -> ``evaluated''
371 \ menuset1_init[x] -> menu_init[x]
372 \ menuset1_kernel -> menu_kernel
373 \ menuset1_keycode[x] -> menu_keycode[x]
374 \ menuset1_options -> menu_options
375 \ menuset1_optionstext -> menu_optionstext
376 \ menuset1_reboot -> menu_reboot
377 \ toggledset1_ansi[x] -> toggled_ansi[x]
378 \ toggledset1_text[x] -> toggled_text[x]
379 \ otherwise, the following variables are referenced (where {name}
380 \ represents the value of $menuset_name1 (given 1 as stack-input):
381 \ {name}ansi_caption[x] -> ansi_caption[x]
382 \ {name}ansi_caption[x][y] -> ansi_caption[x][y]
383 \ {name}menu_acpi -> menu_acpi
384 \ {name}menu_caption[x] -> menu_caption[x]
385 \ {name}menu_caption[x][y] -> menu_caption[x][y]
386 \ {name}menu_command[x] -> menu_command[x]
387 \ {name}menu_init -> ``evaluated''
388 \ {name}menu_init[x] -> menu_init[x]
389 \ {name}menu_kernel -> menu_kernel
390 \ {name}menu_keycode[x] -> menu_keycode[x]
391 \ {name}menu_options -> menu_options
392 \ {name}menu_optionstext -> menu_optionstext
393 \ {name}menu_reboot -> menu_reboot
394 \ {name}toggled_ansi[x] -> toggled_ansi[x]
395 \ {name}toggled_text[x] -> toggled_text[x]
397 \ Note that menuset{N}_init and {name}menu_init are the initializers
398 \ for the entire menu (for wholly dynamic menus) opposed to the per-
399 \ menuitem initializers (with [x] afterward). The whole-menu init
400 \ routine is evaluated and not passed down to $menu_init (which
401 \ would result in double evaluation). By doing this, the initializer
402 \ can initialize the menuset before we transfer it to active-duty.
406 \ Copy our affixation (prefix or infix depending on menuset_use_name)
407 \ to our buffer so that we can safely use the s-quote (s") buf again.
409 menuset_affixbuf 0 2swap ( c-addr2 u2 -- c-addr1 0 c-addr2 u2 )
410 begin ( using u2 in c-addr2/u2 pair as countdown to zero )
411 over ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c-addr2 )
412 c@ ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c )
414 ( c-addr1 u1 c-addr2 u2 c -- continued below )
415 ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
416 + ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- continued below )
417 ( c-addr1 u1 c-addr2 u2 c c-addr3 )
418 c! ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
419 ( c-addr1 u1 c-addr2 u2 )
420 2swap 1+ 2swap \ increment affixbuf byte position/count
421 swap 1+ swap \ increment strbuf pointer (source c-addr2)
422 1- \ decrement strbuf byte count (source u2)
423 dup 0= \ time to break?
425 2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 ) \ drop strbuf c-addr2/u2
428 \ Create a variable for referencing our affix data (prefix or infix
429 \ depending on menuset_use_name as described above). This variable will
430 \ be temporary and only used to simplify cmdbuf assembly.
432 s" affix" setenv ( c-addr1 u1 -- )
435 : menuset-cleanup ( -- )
443 only forth definitions also menusets-infrastructure
445 : menuset-loadsetnum ( N -- )
447 menuset-checksetnum ( n -- )
450 \ From here out, we use temporary environment variables to make
451 \ dealing with variable-length strings easier.
453 \ menuset_use_name is true or false
454 \ $affix should be used appropriately w/respect to menuset_use_name
458 s" set var=init" evaluate
461 \ If menu_init was set by the above, evaluate it here-and-now
462 \ so that the remaining variables are influenced by its actions
463 s" menu_init" 2dup getenv dup -1 <> if
464 2swap unsetenv \ don't want later menu-create to re-call this
467 drop 2drop ( n c-addr u -1 -- n )
470 [char] 1 ( -- x ) \ Loop range ASCII '1' (49) to '8' (56)
472 dup menuset_x tuck c! 1 s" x" setenv \ set loop iterator and $x
474 s" set var=caption" evaluate
476 \ ... menu_caption[x] ...
479 \ ... ansi_caption[x] ...
482 [char] 0 ( x -- x y ) \ Inner Loop ASCII '1' (48) to '9' (57)
484 dup menuset_y tuck c! 1 s" y" setenv
485 \ set inner loop iterator and $y
487 \ ... menu_caption[x][y] ...
488 menuset-loadmenuxyvar
490 \ ... ansi_caption[x][y] ...
491 menuset-loadansixyvar
493 1+ dup 57 > ( x y -- y' 0|-1 ) \ increment and test
497 \ ... menu_command[x] ...
498 s" set var=command" evaluate
501 \ ... menu_init[x] ...
502 s" set var=init" evaluate
505 \ ... menu_keycode[x] ...
506 s" set var=keycode" evaluate
509 \ ... toggled_text[x] ...
510 s" set var=text" evaluate
511 menuset-loadtoggledxvar
513 \ ... toggled_ansi[x] ...
514 s" set var=ansi" evaluate
515 menuset-loadtoggledxvar
517 1+ dup 56 > ( x -- x' 0|-1 ) \ increment iterator
518 \ continue if less than 57
520 drop ( x -- ) \ loop iterator
522 \ ... menu_reboot ...
523 s" set var=reboot" evaluate
527 s" set var=acpi" evaluate
530 \ ... menu_kernel ...
531 s" set var=kernel" evaluate
534 \ ... menu_options ...
535 s" set var=options" evaluate
538 \ ... menu_optionstext ...
539 s" set var=optionstext" evaluate
545 : menusets-unset ( -- )
547 s" menuset_initial" unsetenv
550 dup menuset-checksetnum ( n n -- n )
552 dup menuset-setnum-namevar ( n n -- n )
555 \ If the current menuset does not populate the first menuitem,
556 \ we stop completely.
558 menuset_use_name @ true = if
559 s" set buf=${affix}menu_caption[1]"
561 s" set buf=menuset${affix}_caption[1]"
563 evaluate s" buf" getenv getenv -1 = if
569 drop ( n c-addr2 -- n ) \ unused
572 [char] 1 ( n -- n x ) \ Loop range ASCII '1' (49) to '8' (56)
574 dup menuset_x tuck c! 1 s" x" setenv \ set $x to x
576 s" set var=caption" evaluate
577 menuset-unloadmenuxvar
578 menuset-unloadmenuxvar
579 menuset-unloadansixvar
580 [char] 0 ( n x -- n x y ) \ Inner loop '0' to '9'
582 dup menuset_y tuck c! 1 s" y" setenv
584 menuset-unloadmenuxyvar
585 menuset-unloadansixyvar
586 1+ dup 57 > ( n x y -- n x y' 0|-1 )
588 drop ( n x y -- n x )
589 s" set var=command" evaluate menuset-unloadmenuxvar
590 s" set var=init" evaluate menuset-unloadmenuxvar
591 s" set var=keycode" evaluate menuset-unloadmenuxvar
592 s" set var=text" evaluate menuset-unloadtoggledxvar
593 s" set var=ansi" evaluate menuset-unloadtoggledxvar
595 1+ dup 56 > ( x -- x' 0|-1 ) \ increment and test
597 drop ( n x -- n ) \ loop iterator
599 s" set var=acpi" evaluate menuset-unloadmenuvar
600 s" set var=init" evaluate menuset-unloadmenuvar
601 s" set var=kernel" evaluate menuset-unloadmenuvar
602 s" set var=options" evaluate menuset-unloadmenuvar
603 s" set var=optionstext" evaluate menuset-unloadmenuvar
604 s" set var=reboot" evaluate menuset-unloadmenuvar
606 1+ dup 65535 > ( n -- n' 0|-1 ) \ increment and test
608 drop ( n' -- ) \ loop iterator
614 only forth definitions
616 : menuset-loadinitial ( -- )
617 s" menuset_initial" getenv dup -1 <> if