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