Merge from vendor branch DIFFUTILS:
[dragonfly.git] / sys / boot / forth / support.4th
1 \ Copyright (c) 1999 Daniel C. Sobral <dcs@freebsd.org>
2 \ All rights reserved.
3
4 \ Redistribution and use in source and binary forms, with or without
5 \ modification, are permitted provided that the following conditions
6 \ are met:
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.
12 \
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
23 \ SUCH DAMAGE.
24 \
25 \ $FreeBSD: src/sys/boot/forth/support.4th,v 1.15 2002/05/24 02:28:58 gordon Exp $
26 \ $DragonFly: src/sys/boot/forth/support.4th,v 1.3 2003/11/10 06:08:34 dillon Exp $
27
28 \ Loader.rc support functions:
29 \
30 \ initialize_support ( -- )     initialize global variables
31 \ initialize ( addr len -- )    as above, plus load_conf_files
32 \ load_conf ( addr len -- )     load conf file given
33 \ include_conf_files ( -- )     load all conf files in load_conf_files
34 \ print_syntax_error ( -- )     print line and marker of where a syntax
35 \                               error was detected
36 \ print_line ( -- )             print last line processed
37 \ load_kernel ( -- )            load kernel
38 \ load_modules ( -- )           load modules flagged
39 \
40 \ Exported structures:
41 \
42 \ string                        counted string structure
43 \       cell .addr                      string address
44 \       cell .len                       string length
45 \ module                        module loading information structure
46 \       cell module.flag                should we load it?
47 \       string module.name              module's name
48 \       string module.loadname          name to be used in loading the module
49 \       string module.type              module's type
50 \       string module.args              flags to be passed during load
51 \       string module.beforeload        command to be executed before load
52 \       string module.afterload         command to be executed after load
53 \       string module.loaderror         command to be executed if load fails
54 \       cell module.next                list chain
55 \
56 \ Exported global variables;
57 \
58 \ string conf_files             configuration files to be loaded
59 \ string password               password
60 \ cell modules_options          pointer to first module information
61 \ value verbose?                indicates if user wants a verbose loading
62 \ value any_conf_read?          indicates if a conf file was succesfully read
63 \
64 \ Other exported words:
65 \
66 \ strdup ( addr len -- addr' len)                       similar to strdup(3)
67 \ strcat ( addr len addr' len' -- addr len+len' )       similar to strcat(3)
68 \ strlen ( addr -- len )                                similar to strlen(3)
69 \ s' ( | string' -- addr len | )                        similar to s"
70 \ rudimentary structure support
71
72 \ Exception values
73
74 1 constant syntax_error
75 2 constant out_of_memory
76 3 constant free_error
77 4 constant set_error
78 5 constant read_error
79 6 constant open_error
80 7 constant exec_error
81 8 constant before_load_error
82 9 constant after_load_error
83
84 \ I/O constants
85
86 0 constant SEEK_SET
87 1 constant SEEK_CUR
88 2 constant SEEK_END
89
90 0 constant O_RDONLY
91 1 constant O_WRONLY
92 2 constant O_RDWR
93
94 \ Crude structure support
95
96 : structure:
97   create here 0 , ['] drop , 0
98   does> create here swap dup @ allot cell+ @ execute
99 ;
100 : member: create dup , over , + does> cell+ @ + ;
101 : ;structure swap ! ;
102 : constructor! >body cell+ ! ;
103 : constructor: over :noname ;
104 : ;constructor postpone ; swap cell+ ! ; immediate
105 : sizeof ' >body @ state @ if postpone literal then ; immediate
106 : offsetof ' >body cell+ @ state @ if postpone literal then ; immediate
107 : ptr 1 cells member: ;
108 : int 1 cells member: ;
109
110 \ String structure
111
112 structure: string
113         ptr .addr
114         int .len
115         constructor:
116           0 over .addr !
117           0 swap .len !
118         ;constructor
119 ;structure
120
121
122 \ Module options linked list
123
124 structure: module
125         int module.flag
126         sizeof string member: module.name
127         sizeof string member: module.loadname
128         sizeof string member: module.type
129         sizeof string member: module.args
130         sizeof string member: module.beforeload
131         sizeof string member: module.afterload
132         sizeof string member: module.loaderror
133         ptr module.next
134 ;structure
135
136 \ Internal loader structures
137 structure: preloaded_file
138         ptr pf.name
139         ptr pf.type
140         ptr pf.args
141         ptr pf.metadata \ file_metadata
142         int pf.loader
143         int pf.addr
144         int pf.size
145         ptr pf.modules  \ kernel_module
146         ptr pf.next     \ preloaded_file
147 ;structure
148
149 structure: kernel_module
150         ptr km.name
151         \ ptr km.args
152         ptr km.fp       \ preloaded_file
153         ptr km.next     \ kernel_module
154 ;structure
155
156 structure: file_metadata
157         int             md.size
158         2 member:       md.type \ this is not ANS Forth compatible (XXX)
159         ptr             md.next \ file_metadata
160         0 member:       md.data \ variable size
161 ;structure
162
163 structure: config_resource
164         ptr cf.name
165         int cf.type
166 0 constant RES_INT
167 1 constant RES_STRING
168 2 constant RES_LONG
169         2 cells member: u
170 ;structure
171
172 structure: config_device
173         ptr cd.name
174         int cd.unit
175         int cd.resource_count
176         ptr cd.resources        \ config_resource
177 ;structure
178
179 structure: STAILQ_HEAD
180         ptr stqh_first  \ type*
181         ptr stqh_last   \ type**
182 ;structure
183
184 structure: STAILQ_ENTRY
185         ptr stqe_next   \ type*
186 ;structure
187
188 structure: pnphandler
189         ptr pnph.name
190         ptr pnph.enumerate
191 ;structure
192
193 structure: pnpident
194         ptr pnpid.ident                                 \ char*
195         sizeof STAILQ_ENTRY cells member: pnpid.link    \ pnpident
196 ;structure
197
198 structure: pnpinfo
199         ptr pnpi.desc
200         int pnpi.revision
201         ptr pnpi.module                         \ (char*) module args
202         int pnpi.argc
203         ptr pnpi.argv
204         ptr pnpi.handler                        \ pnphandler
205         sizeof STAILQ_HEAD member: pnpi.ident   \ pnpident
206         sizeof STAILQ_ENTRY member: pnpi.link   \ pnpinfo
207 ;structure
208
209 \ Global variables
210
211 string conf_files
212 string nextboot_conf_file
213 string password
214 create module_options sizeof module.next allot 0 module_options !
215 create last_module_option sizeof module.next allot 0 last_module_option !
216 0 value verbose?
217 0 value nextboot?
218
219 \ Support string functions
220
221 : strdup  ( addr len -- addr' len )
222   >r r@ allocate if out_of_memory throw then
223   tuck r@ move
224   r>
225 ;
226
227 : strcat  { addr len addr' len' -- addr len+len' }
228   addr' addr len + len' move
229   addr len len' +
230 ;
231
232 : strlen ( addr -- len )
233   0 >r
234   begin
235     dup c@ while
236     1+ r> 1+ >r repeat
237   drop r>
238 ;
239
240 : s' 
241   [char] ' parse
242   state @ if
243     postpone sliteral
244   then
245 ; immediate
246
247 : 2>r postpone >r postpone >r ; immediate
248 : 2r> postpone r> postpone r> ; immediate
249 : 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate
250
251 : getenv?
252   getenv
253   -1 = if false else drop true then
254 ;
255
256 \ Private definitions
257
258 vocabulary support-functions
259 only forth also support-functions definitions
260
261 \ Some control characters constants
262
263 7 constant bell
264 8 constant backspace
265 9 constant tab
266 10 constant lf
267 13 constant <cr>
268
269 \ Read buffer size
270
271 80 constant read_buffer_size
272
273 \ Standard suffixes
274
275 : load_module_suffix s" _load" ;
276 : module_loadname_suffix s" _name" ;
277 : module_type_suffix s" _type" ;
278 : module_args_suffix s" _flags" ;
279 : module_beforeload_suffix s" _before" ;
280 : module_afterload_suffix s" _after" ;
281 : module_loaderror_suffix s" _error" ;
282
283 \ Support operators
284
285 : >= < 0= ;
286 : <= > 0= ;
287
288 \ Assorted support funcitons
289
290 : free-memory free if free_error throw then ;
291
292 \ Assignment data temporary storage
293
294 string name_buffer
295 string value_buffer
296
297 \ Line by line file reading functions
298 \
299 \ exported:
300 \       line_buffer
301 \       end_of_file?
302 \       fd
303 \       read_line
304 \       reset_line_reading
305
306 vocabulary line-reading
307 also line-reading definitions also
308
309 \ File data temporary storage
310
311 string read_buffer
312 0 value read_buffer_ptr
313
314 \ File's line reading function
315
316 support-functions definitions
317
318 string line_buffer
319 0 value end_of_file?
320 variable fd
321
322 line-reading definitions
323
324 : skip_newlines
325   begin
326     read_buffer .len @ read_buffer_ptr >
327   while
328     read_buffer .addr @ read_buffer_ptr + c@ lf = if
329       read_buffer_ptr char+ to read_buffer_ptr
330     else
331       exit
332     then
333   repeat
334 ;
335
336 : scan_buffer  ( -- addr len )
337   read_buffer_ptr >r
338   begin
339     read_buffer .len @ r@ >
340   while
341     read_buffer .addr @ r@ + c@ lf = if
342       read_buffer .addr @ read_buffer_ptr +  ( -- addr )
343       r@ read_buffer_ptr -                   ( -- len )
344       r> to read_buffer_ptr
345       exit
346     then
347     r> char+ >r
348   repeat
349   read_buffer .addr @ read_buffer_ptr +  ( -- addr )
350   r@ read_buffer_ptr -                   ( -- len )
351   r> to read_buffer_ptr
352 ;
353
354 : line_buffer_resize  ( len -- len )
355   >r
356   line_buffer .len @ if
357     line_buffer .addr @
358     line_buffer .len @ r@ +
359     resize if out_of_memory throw then
360   else
361     r@ allocate if out_of_memory throw then
362   then
363   line_buffer .addr !
364   r>
365 ;
366     
367 : append_to_line_buffer  ( addr len -- )
368   line_buffer .addr @ line_buffer .len @
369   2swap strcat
370   line_buffer .len !
371   drop
372 ;
373
374 : read_from_buffer
375   scan_buffer            ( -- addr len )
376   line_buffer_resize     ( len -- len )
377   append_to_line_buffer  ( addr len -- )
378 ;
379
380 : refill_required?
381   read_buffer .len @ read_buffer_ptr =
382   end_of_file? 0= and
383 ;
384
385 : refill_buffer
386   0 to read_buffer_ptr
387   read_buffer .addr @ 0= if
388     read_buffer_size allocate if out_of_memory throw then
389     read_buffer .addr !
390   then
391   fd @ read_buffer .addr @ read_buffer_size fread
392   dup -1 = if read_error throw then
393   dup 0= if true to end_of_file? then
394   read_buffer .len !
395 ;
396
397 : reset_line_buffer
398   line_buffer .addr @ ?dup if
399     free-memory
400   then
401   0 line_buffer .addr !
402   0 line_buffer .len !
403 ;
404
405 support-functions definitions
406
407 : reset_line_reading
408   0 to read_buffer_ptr
409 ;
410
411 : read_line
412   reset_line_buffer
413   skip_newlines
414   begin
415     read_from_buffer
416     refill_required?
417   while
418     refill_buffer
419   repeat
420 ;
421
422 only forth also support-functions definitions
423
424 \ Conf file line parser:
425 \ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
426 \            <spaces>[<comment>]
427 \ <name> ::= <letter>{<letter>|<digit>|'_'}
428 \ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name>
429 \ <character_set> ::= ASCII 32 to 126, except '\' and '"'
430 \ <comment> ::= '#'{<anything>}
431 \
432 \ exported:
433 \       line_pointer
434 \       process_conf
435
436 0 value line_pointer
437
438 vocabulary file-processing
439 also file-processing definitions
440
441 \ parser functions
442 \
443 \ exported:
444 \       get_assignment
445
446 vocabulary parser
447 also parser definitions also
448
449 0 value parsing_function
450 0 value end_of_line
451
452 : end_of_line?
453   line_pointer end_of_line =
454 ;
455
456 : letter?
457   line_pointer c@ >r
458   r@ [char] A >=
459   r@ [char] Z <= and
460   r@ [char] a >=
461   r> [char] z <= and
462   or
463 ;
464
465 : digit?
466   line_pointer c@ >r
467   r@ [char] 0 >=
468   r> [char] 9 <= and
469 ;
470
471 : quote?
472   line_pointer c@ [char] " =
473 ;
474
475 : assignment_sign?
476   line_pointer c@ [char] = =
477 ;
478
479 : comment?
480   line_pointer c@ [char] # =
481 ;
482
483 : space?
484   line_pointer c@ bl =
485   line_pointer c@ tab = or
486 ;
487
488 : backslash?
489   line_pointer c@ [char] \ =
490 ;
491
492 : underscore?
493   line_pointer c@ [char] _ =
494 ;
495
496 : dot?
497   line_pointer c@ [char] . =
498 ;
499
500 : skip_character
501   line_pointer char+ to line_pointer
502 ;
503
504 : skip_to_end_of_line
505   end_of_line to line_pointer
506 ;
507
508 : eat_space
509   begin
510     space?
511   while
512     skip_character
513     end_of_line? if exit then
514   repeat
515 ;
516
517 : parse_name  ( -- addr len )
518   line_pointer
519   begin
520     letter? digit? underscore? dot? or or or
521   while
522     skip_character
523     end_of_line? if 
524       line_pointer over -
525       strdup
526       exit
527     then
528   repeat
529   line_pointer over -
530   strdup
531 ;
532
533 : remove_backslashes  { addr len | addr' len' -- addr' len' }
534   len allocate if out_of_memory throw then
535   to addr'
536   addr >r
537   begin
538     addr c@ [char] \ <> if
539       addr c@ addr' len' + c!
540       len' char+ to len'
541     then
542     addr char+ to addr
543     r@ len + addr =
544   until
545   r> drop
546   addr' len'
547 ;
548
549 : parse_quote  ( -- addr len )
550   line_pointer
551   skip_character
552   end_of_line? if syntax_error throw then
553   begin
554     quote? 0=
555   while
556     backslash? if
557       skip_character
558       end_of_line? if syntax_error throw then
559     then
560     skip_character
561     end_of_line? if syntax_error throw then 
562   repeat
563   skip_character
564   line_pointer over -
565   remove_backslashes
566 ;
567
568 : read_name
569   parse_name            ( -- addr len )
570   name_buffer .len !
571   name_buffer .addr !
572 ;
573
574 : read_value
575   quote? if
576     parse_quote         ( -- addr len )
577   else
578     parse_name          ( -- addr len )
579   then
580   value_buffer .len !
581   value_buffer .addr !
582 ;
583
584 : comment
585   skip_to_end_of_line
586 ;
587
588 : white_space_4
589   eat_space
590   comment? if ['] comment to parsing_function exit then
591   end_of_line? 0= if syntax_error throw then
592 ;
593
594 : variable_value
595   read_value
596   ['] white_space_4 to parsing_function
597 ;
598
599 : white_space_3
600   eat_space
601   letter? digit? quote? or or if
602     ['] variable_value to parsing_function exit
603   then
604   syntax_error throw
605 ;
606
607 : assignment_sign
608   skip_character
609   ['] white_space_3 to parsing_function
610 ;
611
612 : white_space_2
613   eat_space
614   assignment_sign? if ['] assignment_sign to parsing_function exit then
615   syntax_error throw
616 ;
617
618 : variable_name
619   read_name
620   ['] white_space_2 to parsing_function
621 ;
622
623 : white_space_1
624   eat_space
625   letter?  if ['] variable_name to parsing_function exit then
626   comment? if ['] comment to parsing_function exit then
627   end_of_line? 0= if syntax_error throw then
628 ;
629
630 file-processing definitions
631
632 : get_assignment
633   line_buffer .addr @ line_buffer .len @ + to end_of_line
634   line_buffer .addr @ to line_pointer
635   ['] white_space_1 to parsing_function
636   begin
637     end_of_line? 0=
638   while
639     parsing_function execute
640   repeat
641   parsing_function ['] comment =
642   parsing_function ['] white_space_1 =
643   parsing_function ['] white_space_4 =
644   or or 0= if syntax_error throw then
645 ;
646
647 only forth also support-functions also file-processing definitions also
648
649 \ Process line
650
651 : assignment_type?  ( addr len -- flag )
652   name_buffer .addr @ name_buffer .len @
653   compare 0=
654 ;
655
656 : suffix_type?  ( addr len -- flag )
657   name_buffer .len @ over <= if 2drop false exit then
658   name_buffer .len @ over - name_buffer .addr @ +
659   over compare 0=
660 ;
661
662 : loader_conf_files?
663   s" loader_conf_files" assignment_type?
664 ;
665
666 : nextboot_flag?
667   s" nextboot_enable" assignment_type?
668 ;
669
670 : nextboot_conf?
671   s" nextboot_conf" assignment_type?
672 ;
673
674 : verbose_flag?
675   s" verbose_loading" assignment_type?
676 ;
677
678 : execute?
679   s" exec" assignment_type?
680 ;
681
682 : password?
683   s" password" assignment_type?
684 ;
685
686 : module_load?
687   load_module_suffix suffix_type?
688 ;
689
690 : module_loadname?
691   module_loadname_suffix suffix_type?
692 ;
693
694 : module_type?
695   module_type_suffix suffix_type?
696 ;
697
698 : module_args?
699   module_args_suffix suffix_type?
700 ;
701
702 : module_beforeload?
703   module_beforeload_suffix suffix_type?
704 ;
705
706 : module_afterload?
707   module_afterload_suffix suffix_type?
708 ;
709
710 : module_loaderror?
711   module_loaderror_suffix suffix_type?
712 ;
713
714 : set_conf_files
715   conf_files .addr @ ?dup if
716     free-memory
717   then
718   value_buffer .addr @ c@ [char] " = if
719     value_buffer .addr @ char+ value_buffer .len @ 2 chars -
720   else
721     value_buffer .addr @ value_buffer .len @
722   then
723   strdup
724   conf_files .len ! conf_files .addr !
725 ;
726
727 : set_nextboot_conf
728   nextboot_conf_file .addr @ ?dup if
729     free-memory
730   then
731   value_buffer .addr @ c@ [char] " = if
732     value_buffer .addr @ char+ value_buffer .len @ 2 chars -
733   else
734     value_buffer .addr @ value_buffer .len @
735   then
736   strdup
737   nextboot_conf_file .len ! nextboot_conf_file .addr !
738 ;
739
740 : append_to_module_options_list  ( addr -- )
741   module_options @ 0= if
742     dup module_options !
743     last_module_option !
744   else
745     dup last_module_option @ module.next !
746     last_module_option !
747   then
748 ;
749
750 : set_module_name  ( addr -- )
751   name_buffer .addr @ name_buffer .len @
752   strdup
753   >r over module.name .addr !
754   r> swap module.name .len !
755 ;
756
757 : yes_value?
758   value_buffer .addr @ value_buffer .len @
759   2dup s' "YES"' compare >r
760   2dup s' "yes"' compare >r
761   2dup s" YES" compare >r
762   s" yes" compare r> r> r> and and and 0=
763 ;
764
765 : find_module_option  ( -- addr | 0 )
766   module_options @
767   begin
768     dup
769   while
770     dup module.name dup .addr @ swap .len @
771     name_buffer .addr @ name_buffer .len @
772     compare 0= if exit then
773     module.next @
774   repeat
775 ;
776
777 : new_module_option  ( -- addr )
778   sizeof module allocate if out_of_memory throw then
779   dup sizeof module erase
780   dup append_to_module_options_list
781   dup set_module_name
782 ;
783
784 : get_module_option  ( -- addr )
785   find_module_option
786   ?dup 0= if new_module_option then
787 ;
788
789 : set_module_flag
790   name_buffer .len @ load_module_suffix nip - name_buffer .len !
791   yes_value? get_module_option module.flag !
792 ;
793
794 : set_module_args
795   name_buffer .len @ module_args_suffix nip - name_buffer .len !
796   get_module_option module.args
797   dup .addr @ ?dup if free-memory then
798   value_buffer .addr @ value_buffer .len @
799   over c@ [char] " = if
800     2 chars - swap char+ swap
801   then
802   strdup
803   >r over .addr !
804   r> swap .len !
805 ;
806
807 : set_module_loadname
808   name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
809   get_module_option module.loadname
810   dup .addr @ ?dup if free-memory then
811   value_buffer .addr @ value_buffer .len @
812   over c@ [char] " = if
813     2 chars - swap char+ swap
814   then
815   strdup
816   >r over .addr !
817   r> swap .len !
818 ;
819
820 : set_module_type
821   name_buffer .len @ module_type_suffix nip - name_buffer .len !
822   get_module_option module.type
823   dup .addr @ ?dup if free-memory then
824   value_buffer .addr @ value_buffer .len @
825   over c@ [char] " = if
826     2 chars - swap char+ swap
827   then
828   strdup
829   >r over .addr !
830   r> swap .len !
831 ;
832
833 : set_module_beforeload
834   name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
835   get_module_option module.beforeload
836   dup .addr @ ?dup if free-memory then
837   value_buffer .addr @ value_buffer .len @
838   over c@ [char] " = if
839     2 chars - swap char+ swap
840   then
841   strdup
842   >r over .addr !
843   r> swap .len !
844 ;
845
846 : set_module_afterload
847   name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
848   get_module_option module.afterload
849   dup .addr @ ?dup if free-memory then
850   value_buffer .addr @ value_buffer .len @
851   over c@ [char] " = if
852     2 chars - swap char+ swap
853   then
854   strdup
855   >r over .addr !
856   r> swap .len !
857 ;
858
859 : set_module_loaderror
860   name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
861   get_module_option module.loaderror
862   dup .addr @ ?dup if free-memory then
863   value_buffer .addr @ value_buffer .len @
864   over c@ [char] " = if
865     2 chars - swap char+ swap
866   then
867   strdup
868   >r over .addr !
869   r> swap .len !
870 ;
871
872 : set_environment_variable
873   name_buffer .len @
874   value_buffer .len @ +
875   5 chars +
876   allocate if out_of_memory throw then
877   dup 0  ( addr -- addr addr len )
878   s" set " strcat
879   name_buffer .addr @ name_buffer .len @ strcat
880   s" =" strcat
881   value_buffer .addr @ value_buffer .len @ strcat
882   ['] evaluate catch if
883     2drop free drop
884     set_error throw
885   else
886     free-memory
887   then
888 ;
889
890 : set_nextboot_flag
891   yes_value? to nextboot?
892 ;
893
894 : set_verbose
895   yes_value? to verbose?
896 ;
897
898 : execute_command
899   value_buffer .addr @ value_buffer .len @
900   over c@ [char] " = if
901     2 - swap char+ swap
902   then
903   ['] evaluate catch if exec_error throw then
904 ;
905
906 : set_password
907   password .addr @ ?dup if free if free_error throw then then
908   value_buffer .addr @ c@ [char] " = if
909     value_buffer .addr @ char+ value_buffer .len @ 2 - strdup
910     value_buffer .addr @ free if free_error throw then
911   else
912     value_buffer .addr @ value_buffer .len @
913   then
914   password .len ! password .addr !
915   0 value_buffer .addr !
916 ;
917
918 : process_assignment
919   name_buffer .len @ 0= if exit then
920   loader_conf_files?    if set_conf_files exit then
921   nextboot_flag?        if set_nextboot_flag exit then
922   nextboot_conf?        if set_nextboot_conf exit then
923   verbose_flag?         if set_verbose exit then
924   execute?              if execute_command exit then
925   password?             if set_password exit then
926   module_load?          if set_module_flag exit then
927   module_loadname?      if set_module_loadname exit then
928   module_type?          if set_module_type exit then
929   module_args?          if set_module_args exit then
930   module_beforeload?    if set_module_beforeload exit then
931   module_afterload?     if set_module_afterload exit then
932   module_loaderror?     if set_module_loaderror exit then
933   set_environment_variable
934 ;
935
936 \ free_buffer  ( -- )
937 \
938 \ Free some pointers if needed. The code then tests for errors
939 \ in freeing, and throws an exception if needed. If a pointer is
940 \ not allocated, it's value (0) is used as flag.
941
942 : free_buffers
943   name_buffer .addr @ dup if free then
944   value_buffer .addr @ dup if free then
945   or if free_error throw then
946 ;
947
948 : reset_assignment_buffers
949   0 name_buffer .addr !
950   0 name_buffer .len !
951   0 value_buffer .addr !
952   0 value_buffer .len !
953 ;
954
955 \ Higher level file processing
956
957 support-functions definitions
958
959 : process_conf
960   begin
961     end_of_file? 0=
962   while
963     reset_assignment_buffers
964     read_line
965     get_assignment
966     ['] process_assignment catch
967     ['] free_buffers catch
968     swap throw throw
969   repeat
970 ;
971
972 : peek_file
973   0 to end_of_file?
974   reset_line_reading
975   O_RDONLY fopen fd !
976   fd @ -1 = if open_error throw then
977   reset_assignment_buffers
978   read_line
979   get_assignment
980   ['] process_assignment catch
981   ['] free_buffers catch
982   fd @ fclose
983 ;
984   
985 only forth also support-functions definitions
986
987 \ Interface to loading conf files
988
989 : load_conf  ( addr len -- )
990   0 to end_of_file?
991   reset_line_reading
992   O_RDONLY fopen fd !
993   fd @ -1 = if open_error throw then
994   ['] process_conf catch
995   fd @ fclose
996   throw
997 ;
998
999 : print_line
1000   line_buffer .addr @ line_buffer .len @ type cr
1001 ;
1002
1003 : print_syntax_error
1004   line_buffer .addr @ line_buffer .len @ type cr
1005   line_buffer .addr @
1006   begin
1007     line_pointer over <>
1008   while
1009     bl emit
1010     char+
1011   repeat
1012   drop
1013   ." ^" cr
1014 ;
1015
1016 \ Depuration support functions
1017
1018 only forth definitions also support-functions
1019
1020 : test-file 
1021   ['] load_conf catch dup .
1022   syntax_error = if cr print_syntax_error then
1023 ;
1024
1025 : show-module-options
1026   module_options @
1027   begin
1028     ?dup
1029   while
1030     ." Name: " dup module.name dup .addr @ swap .len @ type cr
1031     ." Path: " dup module.loadname dup .addr @ swap .len @ type cr
1032     ." Type: " dup module.type dup .addr @ swap .len @ type cr
1033     ." Flags: " dup module.args dup .addr @ swap .len @ type cr
1034     ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr
1035     ." After load: " dup module.afterload dup .addr @ swap .len @ type cr
1036     ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr
1037     ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr
1038     module.next @
1039   repeat
1040 ;
1041
1042 only forth also support-functions definitions
1043
1044 \ Variables used for processing multiple conf files
1045
1046 string current_file_name
1047 variable current_conf_files
1048
1049 \ Indicates if any conf file was succesfully read
1050
1051 0 value any_conf_read?
1052
1053 \ loader_conf_files processing support functions
1054
1055 : set_current_conf_files
1056   conf_files .addr @ current_conf_files !
1057 ;
1058
1059 : get_conf_files
1060   conf_files .addr @ conf_files .len @ strdup
1061 ;
1062
1063 : recurse_on_conf_files?
1064   current_conf_files @ conf_files .addr @ <>
1065 ;
1066
1067 : skip_leading_spaces  { addr len pos -- addr len pos' }
1068   begin
1069     pos len = if addr len pos exit then
1070     addr pos + c@ bl =
1071   while
1072     pos char+ to pos
1073   repeat
1074   addr len pos
1075 ;
1076
1077 : get_file_name  { addr len pos -- addr len pos' addr' len' || 0 }
1078   pos len = if 
1079     addr free abort" Fatal error freeing memory"
1080     0 exit
1081   then
1082   pos >r
1083   begin
1084     addr pos + c@ bl <>
1085   while
1086     pos char+ to pos
1087     pos len = if
1088       addr len pos addr r@ + pos r> - exit
1089     then
1090   repeat
1091   addr len pos addr r@ + pos r> -
1092 ;
1093
1094 : get_next_file  ( addr len ptr -- addr len ptr' addr' len' | 0 )
1095   skip_leading_spaces
1096   get_file_name
1097 ;
1098
1099 : set_current_file_name
1100   over current_file_name .addr !
1101   dup current_file_name .len !
1102 ;
1103
1104 : print_current_file
1105   current_file_name .addr @ current_file_name .len @ type
1106 ;
1107
1108 : process_conf_errors
1109   dup 0= if true to any_conf_read? drop exit then
1110   >r 2drop r>
1111   dup syntax_error = if
1112     ." Warning: syntax error on file " print_current_file cr
1113     print_syntax_error drop exit
1114   then
1115   dup set_error = if
1116     ." Warning: bad definition on file " print_current_file cr
1117     print_line drop exit
1118   then
1119   dup read_error = if
1120     ." Warning: error reading file " print_current_file cr drop exit
1121   then
1122   dup open_error = if
1123     verbose? if ." Warning: unable to open file " print_current_file cr then
1124     drop exit
1125   then
1126   dup free_error = abort" Fatal error freeing memory"
1127   dup out_of_memory = abort" Out of memory"
1128   throw  \ Unknown error -- pass ahead
1129 ;
1130
1131 \ Process loader_conf_files recursively
1132 \ Interface to loader_conf_files processing
1133
1134 : include_conf_files
1135   set_current_conf_files
1136   get_conf_files 0
1137   begin
1138     get_next_file ?dup
1139   while
1140     set_current_file_name
1141     ['] load_conf catch
1142     process_conf_errors
1143     recurse_on_conf_files? if recurse then
1144   repeat
1145 ;
1146
1147 : get_nextboot_conf_file ( -- addr len )
1148   nextboot_conf_file .addr @ nextboot_conf_file .len @ strdup
1149 ;
1150
1151 : rewrite_nextboot_file ( -- )
1152   get_nextboot_conf_file
1153   O_WRONLY fopen fd !
1154   fd @ -1 = if open_error throw then
1155   fd @ s' nextboot_enable="NO" ' fwrite
1156   fd @ fclose
1157 ;
1158
1159 : include_nextboot_file
1160   get_nextboot_conf_file
1161   ['] peek_file catch
1162   nextboot? if
1163     get_nextboot_conf_file
1164     ['] load_conf catch
1165     process_conf_errors
1166     ['] rewrite_nextboot_file catch
1167   then
1168 ;
1169
1170 \ Module loading functions
1171
1172 : load_module?
1173   module.flag @
1174 ;
1175
1176 : load_parameters  ( addr -- addr addrN lenN ... addr1 len1 N )
1177   dup >r
1178   r@ module.args .addr @ r@ module.args .len @
1179   r@ module.loadname .len @ if
1180     r@ module.loadname .addr @ r@ module.loadname .len @
1181   else
1182     r@ module.name .addr @ r@ module.name .len @
1183   then
1184   r@ module.type .len @ if
1185     r@ module.type .addr @ r@ module.type .len @
1186     s" -t "
1187     4 ( -t type name flags )
1188   else
1189     2 ( name flags )
1190   then
1191   r> drop
1192 ;
1193
1194 : before_load  ( addr -- addr )
1195   dup module.beforeload .len @ if
1196     dup module.beforeload .addr @ over module.beforeload .len @
1197     ['] evaluate catch if before_load_error throw then
1198   then
1199 ;
1200
1201 : after_load  ( addr -- addr )
1202   dup module.afterload .len @ if
1203     dup module.afterload .addr @ over module.afterload .len @
1204     ['] evaluate catch if after_load_error throw then
1205   then
1206 ;
1207
1208 : load_error  ( addr -- addr )
1209   dup module.loaderror .len @ if
1210     dup module.loaderror .addr @ over module.loaderror .len @
1211     evaluate  \ This we do not intercept so it can throw errors
1212   then
1213 ;
1214
1215 : pre_load_message  ( addr -- addr )
1216   verbose? if
1217     dup module.name .addr @ over module.name .len @ type
1218     ." ..."
1219   then
1220 ;
1221
1222 : load_error_message verbose? if ." failed!" cr then ;
1223
1224 : load_succesful_message verbose? if ." ok" cr then ;
1225
1226 : load_module
1227   load_parameters load
1228 ;
1229
1230 : process_module  ( addr -- addr )
1231   pre_load_message
1232   before_load
1233   begin
1234     ['] load_module catch if
1235       dup module.loaderror .len @ if
1236         load_error                      \ Command should return a flag!
1237       else 
1238         load_error_message true         \ Do not retry
1239       then
1240     else
1241       after_load
1242       load_succesful_message true       \ Succesful, do not retry
1243     then
1244   until
1245 ;
1246
1247 : process_module_errors  ( addr ior -- )
1248   dup before_load_error = if
1249     drop
1250     ." Module "
1251     dup module.name .addr @ over module.name .len @ type
1252     dup module.loadname .len @ if
1253       ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1254     then
1255     cr
1256     ." Error executing "
1257     dup module.beforeload .addr @ over module.afterload .len @ type cr
1258     abort
1259   then
1260
1261   dup after_load_error = if
1262     drop
1263     ." Module "
1264     dup module.name .addr @ over module.name .len @ type
1265     dup module.loadname .len @ if
1266       ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
1267     then
1268     cr
1269     ." Error executing "
1270     dup module.afterload .addr @ over module.afterload .len @ type cr
1271     abort
1272   then
1273
1274   throw  \ Don't know what it is all about -- pass ahead
1275 ;
1276
1277 \ Module loading interface
1278
1279 : load_modules  ( -- ) ( throws: abort & user-defined )
1280   module_options @
1281   begin
1282     ?dup
1283   while
1284     dup load_module? if
1285       ['] process_module catch
1286       process_module_errors
1287     then
1288     module.next @
1289   repeat
1290 ;
1291
1292 \ h00h00 magic used to try loading either a kernel with a given name,
1293 \ or a kernel with the default name in a directory of a given name
1294 \ (the pain!)
1295
1296 : bootpath s" /boot/" ;
1297 : modulepath s" module_path" ;
1298
1299 \ Functions used to save and restore module_path's value.
1300 : saveenv ( addr len | -1 -- addr' len | 0 -1 )
1301   dup -1 = if 0 swap exit then
1302   strdup
1303 ;
1304 : freeenv ( addr len | 0 -1 )
1305   -1 = if drop else free abort" Freeing error" then
1306 ;
1307 : restoreenv  ( addr len | 0 -1 -- )
1308   dup -1 = if ( it wasn't set )
1309     2drop
1310     modulepath unsetenv
1311   else
1312     over >r
1313     modulepath setenv
1314     r> free abort" Freeing error"
1315   then
1316 ;
1317
1318 : clip_args   \ Drop second string if only one argument is passed
1319   1 = if
1320     2swap 2drop
1321     1
1322   else
1323     2
1324   then
1325 ;
1326
1327 also builtins
1328
1329 \ Parse filename from a comma-separated list
1330
1331 : parse-; ( addr len -- addr' len-x addr x )
1332   over 0 2swap
1333   begin
1334     dup 0 <>
1335   while
1336     over c@ [char] ; <>
1337   while
1338     1- swap 1+ swap
1339     2swap 1+ 2swap
1340   repeat then
1341   dup 0 <> if
1342     1- swap 1+ swap
1343   then
1344   2swap
1345 ;
1346
1347 \ Try loading one of multiple kernels specified
1348
1349 : try_multiple_kernels ( addr len addr' len' args -- flag )
1350   >r
1351   begin
1352     parse-; 2>r
1353     2over 2r>
1354     r@ clip_args
1355     s" DEBUG" getenv? if
1356       s" echo Module_path: ${module_path}" evaluate
1357       ." Kernel     : " >r 2dup type r> cr
1358       dup 2 = if ." Flags      : " >r 2over type r> cr then
1359     then
1360     1 load
1361   while
1362     dup 0=
1363   until
1364     1 >r \ Failure
1365   else
1366     0 >r \ Success
1367   then
1368   2drop 2drop
1369   r>
1370   r> drop
1371 ;
1372
1373 \ Try to load a kernel; the kernel name is taken from one of
1374 \ the following lists, as ordered:
1375 \
1376 \   1. The "bootfile" environment variable
1377 \   2. The "kernel" environment variable
1378 \
1379 \ Flags are passed, if available. If not, dummy values must be given.
1380 \
1381 \ The kernel gets loaded from the current module_path.
1382
1383 : load_a_kernel ( flags len 1 | x x 0 -- flag )
1384   local args
1385   2local flags
1386   0 0 2local kernel
1387   end-locals
1388
1389   \ Check if a default kernel name exists at all, exits if not
1390   s" bootfile" getenv dup -1 <> if
1391     to kernel
1392     flags kernel args 1+ try_multiple_kernels
1393     dup 0= if exit then
1394   then
1395   drop
1396
1397   s" kernel" getenv dup -1 <> if
1398     to kernel
1399   else
1400     drop
1401     1 exit \ Failure
1402   then
1403
1404   \ Try all default kernel names
1405   flags kernel args 1+ try_multiple_kernels
1406 ;
1407
1408 \ Try to load a kernel; the kernel name is taken from one of
1409 \ the following lists, as ordered:
1410 \
1411 \   1. The "bootfile" environment variable
1412 \   2. The "kernel" environment variable
1413 \
1414 \ Flags are passed, if provided.
1415 \
1416 \ The kernel will be loaded from a directory computed from the
1417 \ path given. Two directories will be tried in the following order:
1418 \
1419 \   1. /boot/path
1420 \   2. path
1421 \
1422 \ The module_path variable is overridden if load is succesful, by
1423 \ prepending the successful path.
1424
1425 : load_from_directory ( path len 1 | flags len' path len 2 -- flag )
1426   local args
1427   2local path
1428   args 1 = if 0 0 then
1429   2local flags
1430   0 0 2local oldmodulepath
1431   0 0 2local newmodulepath
1432   end-locals
1433
1434   \ Set the environment variable module_path, and try loading
1435   \ the kernel again.
1436   modulepath getenv saveenv to oldmodulepath
1437
1438   \ Try prepending /boot/ first
1439   bootpath nip path nip + 
1440   oldmodulepath nip dup -1 = if
1441     drop
1442   else
1443     1+ +
1444   then
1445   allocate
1446   if ( out of memory )
1447     1 exit
1448   then
1449
1450   0
1451   bootpath strcat
1452   path strcat
1453   2dup to newmodulepath
1454   modulepath setenv
1455
1456   \ Try all default kernel names
1457   flags args 1- load_a_kernel
1458   0= if ( success )
1459     oldmodulepath nip -1 <> if
1460       newmodulepath s" ;" strcat
1461       oldmodulepath strcat
1462       modulepath setenv
1463       newmodulepath drop free-memory
1464       oldmodulepath drop free-memory
1465     then
1466     0 exit
1467   then
1468
1469   \ Well, try without the prepended /boot/
1470   path newmodulepath drop swap move
1471   newmodulepath drop path nip
1472   2dup to newmodulepath
1473   modulepath setenv
1474
1475   \ Try all default kernel names
1476   flags args 1- load_a_kernel
1477   if ( failed once more )
1478     oldmodulepath restoreenv
1479     newmodulepath drop free-memory
1480     1
1481   else
1482     oldmodulepath nip -1 <> if
1483       newmodulepath s" ;" strcat
1484       oldmodulepath strcat
1485       modulepath setenv
1486       newmodulepath drop free-memory
1487       oldmodulepath drop free-memory
1488     then
1489     0
1490   then
1491 ;
1492
1493 \ Try to load a kernel; the kernel name is taken from one of
1494 \ the following lists, as ordered:
1495 \
1496 \   1. The "bootfile" environment variable
1497 \   2. The "kernel" environment variable
1498 \   3. The "path" argument
1499 \
1500 \ Flags are passed, if provided.
1501 \
1502 \ The kernel will be loaded from a directory computed from the
1503 \ path given. Two directories will be tried in the following order:
1504 \
1505 \   1. /boot/path
1506 \   2. path
1507 \
1508 \ Unless "path" is meant to be kernel name itself. In that case, it
1509 \ will first be tried as a full path, and, next, search on the
1510 \ directories pointed by module_path.
1511 \
1512 \ The module_path variable is overridden if load is succesful, by
1513 \ prepending the successful path.
1514
1515 : load_directory_or_file ( path len 1 | flags len' path len 2 -- flag )
1516   local args
1517   2local path
1518   args 1 = if 0 0 then
1519   2local flags
1520   end-locals
1521
1522   \ First, assume path is an absolute path to a directory
1523   flags path args clip_args load_from_directory
1524   dup 0= if exit else drop then
1525
1526   \ Next, assume path points to the kernel
1527   flags path args try_multiple_kernels
1528 ;
1529
1530 : initialize  ( addr len -- )
1531   strdup conf_files .len ! conf_files .addr !
1532 ;
1533
1534 : kernel_options ( -- addr len 1 | 0 )
1535   s" kernel_options" getenv
1536   dup -1 = if drop 0 else 1 then
1537 ;
1538
1539 : standard_kernel_search  ( flags 1 | 0 -- flag )
1540   local args
1541   args 0= if 0 0 then
1542   2local flags
1543   s" kernel" getenv
1544   dup -1 = if 0 swap then
1545   2local path
1546   end-locals
1547
1548   path nip -1 = if ( there isn't a "kernel" environment variable )
1549     flags args load_a_kernel
1550   else
1551     flags path args 1+ clip_args load_directory_or_file
1552   then
1553 ;
1554
1555 : load_kernel  ( -- ) ( throws: abort )
1556   kernel_options standard_kernel_search
1557   abort" Unable to load a kernel!"
1558 ;
1559
1560 : set_defaultoptions  ( -- )
1561   s" kernel_options" getenv dup -1 = if
1562     drop
1563   else
1564     s" temp_options" setenv
1565   then
1566 ;
1567
1568 : argv[]  ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
1569   2dup = if 0 0 exit then
1570   dup >r
1571   1+ 2* ( skip N and ui )
1572   pick
1573   r>
1574   1+ 2* ( skip N and ai )
1575   pick
1576 ;
1577
1578 : drop_args  ( aN uN ... a1 u1 N -- )
1579   0 ?do 2drop loop
1580 ;
1581
1582 : argc
1583   dup
1584 ;
1585
1586 : queue_argv  ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 )
1587   >r
1588   over 2* 1+ -roll
1589   r>
1590   over 2* 1+ -roll
1591   1+
1592 ;
1593
1594 : unqueue_argv  ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 )
1595   1- -rot
1596 ;
1597
1598 : strlen(argv)
1599   dup 0= if 0 exit then
1600   0 >r  \ Size
1601   0 >r  \ Index
1602   begin
1603     argc r@ <>
1604   while
1605     r@ argv[]
1606     nip
1607     r> r> rot + 1+
1608     >r 1+ >r
1609   repeat
1610   r> drop
1611   r>
1612 ;
1613
1614 : concat_argv  ( aN uN ... a1 u1 N -- a u )
1615   strlen(argv) allocate if out_of_memory throw then
1616   0 2>r
1617
1618   begin
1619     argc
1620   while
1621     unqueue_argv
1622     2r> 2swap
1623     strcat
1624     s"  " strcat
1625     2>r
1626   repeat
1627   drop_args
1628   2r>
1629 ;
1630
1631 : set_tempoptions  ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
1632   \ Save the first argument, if it exists and is not a flag
1633   argc if
1634     0 argv[] drop c@ [char] - <> if
1635       unqueue_argv 2>r  \ Filename
1636       1 >r              \ Filename present
1637     else
1638       0 >r              \ Filename not present
1639     then
1640   else
1641     0 >r                \ Filename not present
1642   then
1643
1644   \ If there are other arguments, assume they are flags
1645   ?dup if
1646     concat_argv
1647     2dup s" temp_options" setenv
1648     drop free if free_error throw then
1649   else
1650     set_defaultoptions
1651   then
1652
1653   \ Bring back the filename, if one was provided
1654   r> if 2r> 1 else 0 then
1655 ;
1656
1657 : get_arguments ( -- addrN lenN ... addr1 len1 N )
1658   0
1659   begin
1660     \ Get next word on the command line
1661     parse-word
1662   ?dup while
1663     queue_argv
1664   repeat
1665   drop ( empty string )
1666 ;
1667
1668 : load_kernel_and_modules  ( args -- flag )
1669   set_tempoptions
1670   argc >r
1671   s" temp_options" getenv dup -1 <> if
1672     queue_argv
1673   else
1674     drop
1675   then
1676   r> if ( a path was passed )
1677     load_directory_or_file
1678   else
1679     standard_kernel_search
1680   then
1681   ?dup 0= if ['] load_modules catch then
1682 ;
1683
1684 : read-password { size | buf len -- }
1685   size allocate if out_of_memory throw then
1686   to buf
1687   0 to len
1688   begin
1689     key
1690     dup backspace = if
1691       drop
1692       len if
1693         backspace emit bl emit backspace emit
1694         len 1 - to len
1695       else
1696         bell emit
1697       then
1698     else
1699       dup <cr> = if cr drop buf len exit then
1700       [char] * emit
1701       len size < if
1702         buf len chars + c!
1703       else
1704         drop
1705       then
1706       len 1+ to len
1707     then
1708   again
1709 ;
1710
1711 \ Go back to straight forth vocabulary
1712
1713 only forth also definitions
1714