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