xref: /illumos-gate/usr/src/boot/forth/support.4th (revision 22028508)
1\ Copyright (c) 1999 Daniel C. Sobral <dcs@FreeBSD.org>
2\ Copyright 2019 OmniOS Community Edition (OmniOSce) Association.
3\ All rights reserved.
4\
5\ Redistribution and use in source and binary forms, with or without
6\ modification, are permitted provided that the following conditions
7\ are met:
8\ 1. Redistributions of source code must retain the above copyright
9\    notice, this list of conditions and the following disclaimer.
10\ 2. Redistributions in binary form must reproduce the above copyright
11\    notice, this list of conditions and the following disclaimer in the
12\    documentation and/or other materials provided with the distribution.
13\
14\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
15\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
18\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
19\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
20\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
21\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
22\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
23\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
24\ SUCH DAMAGE.
25
26\ Loader.rc support functions:
27\
28\ initialize ( addr len -- )	as above, plus load_conf_files
29\ load_conf ( addr len -- )	load conf file given
30\ include_bootenv ( -- )	load bootenv.rc
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 (file | hash | rootfs)
48\	string module.hash		module's sha1 hash
49\	string module.args		flags to be passed during load
50\	string module.largs		internal argument list
51\	string module.beforeload	command to be executed before load
52\	string module.afterload		command to be executed after load
53\	string module.loaderror		command to be executed if load fails
54\	cell module.next		list chain
55\
56\ Exported global variables;
57\
58\ string conf_files		configuration files to be loaded
59\ 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 successfully read
62\
63\ Other exported words:
64\    note, strlen is internal
65\ strdup ( addr len -- addr' len)			similar to strdup(3)
66\ strcat ( addr len addr' len' -- addr len+len' )	similar to strcat(3)
67\ s' ( | string' -- addr len | )			similar to s"
68\ rudimentary structure support
69
70\ Exception values
71
721 constant ESYNTAX
732 constant ENOMEM
743 constant EFREE
754 constant ESETERROR	\ error setting environment variable
765 constant EREAD	\ error reading
776 constant EOPEN
787 constant EEXEC	\ XXX never catched
798 constant EBEFORELOAD
809 constant EAFTERLOAD
81
82\ I/O constants
83
840 constant SEEK_SET
851 constant SEEK_CUR
862 constant SEEK_END
87
880 constant O_RDONLY
891 constant O_WRONLY
902 constant O_RDWR
91
92\ Crude structure support
93
94: structure:
95  create here 0 , ['] drop , 0
96  does> create here swap dup @ allot cell+ @ execute
97;
98: member: create dup , over , + does> cell+ @ + ;
99: ;structure swap ! ;
100: constructor! >body cell+ ! ;
101: constructor: over :noname ;
102: ;constructor postpone ; swap cell+ ! ; immediate
103: sizeof ' >body @ state @ if postpone literal then ; immediate
104: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate
105: ptr 1 cells member: ;
106: int 1 cells member: ;
107
108\ String structure
109
110structure: string
111	ptr .addr
112	int .len
113	constructor:
114	  0 over .addr !
115	  0 swap .len !
116	;constructor
117;structure
118
119
120\ Module options linked list
121
122structure: module
123	int module.flag
124	sizeof string member: module.name
125	sizeof string member: module.loadname
126	sizeof string member: module.type
127	sizeof string member: module.hash
128	sizeof string member: module.args
129	sizeof string member: module.largs
130	sizeof string member: module.beforeload
131	sizeof string member: module.afterload
132	sizeof string member: module.loaderror
133	ptr module.next
134;structure
135
136\ Internal loader structures (preloaded_file, kernel_module, file_metadata)
137\ must be in sync with the C struct in sys/boot/common/bootstrap.h
138structure: preloaded_file
139	ptr pf.name
140	ptr pf.type
141	ptr pf.args
142	ptr pf.metadata	\ file_metadata
143	int pf.loader
144	int pf.addr
145	int pf.size
146	ptr pf.modules	\ kernel_module
147	ptr pf.next	\ preloaded_file
148;structure
149
150structure: kernel_module
151	ptr km.name
152	ptr km.args
153	ptr km.fp	\ preloaded_file
154	ptr km.next	\ kernel_module
155;structure
156
157structure: file_metadata
158	int		md.size
159	2 member:	md.type	\ this is not ANS Forth compatible (XXX)
160	ptr		md.next	\ file_metadata
161	0 member:	md.data	\ variable size
162;structure
163
164\ end of structures
165
166\ Global variables
167
168string conf_files
169create module_options sizeof module.next allot 0 module_options !
170create last_module_option sizeof module.next allot 0 last_module_option !
1710 value verbose?
172
173\ Support string functions
174: strdup { addr len -- addr' len' }
175  len allocate if ENOMEM throw then
176  addr over len move len
177;
178
179: strcat  { addr len addr' len' -- addr len+len' }
180  addr' addr len + len' move
181  addr len len' +
182;
183
184: strchr { addr len c -- addr' len' }
185  begin
186    len
187  while
188    addr c@ c = if addr len exit then
189    addr 1 + to addr
190    len 1 - to len
191  repeat
192  0 0
193;
194
195: strspn { addr len addr1 len1 | paddr plen -- addr' len' }
196  begin
197    len
198  while
199    addr1 to paddr
200    len1 to plen
201    begin
202       plen
203    while
204       addr c@ paddr c@ = if addr len exit then
205       paddr 1+ to paddr
206       plen 1- to plen
207    repeat
208    addr 1 + to addr
209    len 1 - to len
210  repeat
211  0 0
212;
213
214: s' \ same as s", allows " in the string
215  [char] ' parse
216  state @ if postpone sliteral then
217; immediate
218
219: 2>r postpone >r postpone >r ; immediate
220: 2r> postpone r> postpone r> ; immediate
221: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate
222
223\ Number to string
224: n2s ( n -- c-addr/u ) s>d <# #s #> ;
225\ String to number
226: s2n ( c-addr/u1 -- u2 | -1 ) ?number 0= if -1 then ;
227
228\ Test if an environment variable is set
229: getenv?  getenv -1 = if false else drop true then ;
230
231\ Fetch a number from an environment variable, or a default if not set or does
232\ not parse (s2n returns -1).
233: getenvn ( n1 c-addr/u -- n1 | n2 )
234	getenv dup -1 = if
235		\ environment variable not set
236		drop		( n1 -1 -- n1 )
237	else
238		s2n		( n1 c-addr/u1 -- n1 n2 )
239		dup -1 = if
240			\ parse failed
241			drop	( n1 n2 -- n1 )
242		else
243			nip	( n1 n2 -- n2 )
244		then
245	then
246;
247
248\ execute xt for each device listed in console variable.
249\ this allows us to have device specific output for logos, menu frames etc
250: console-iterate { xt | caddr clen taddr tlen -- }
251	\ get current console and save it
252	s" console" getenv
253	['] strdup catch if 2drop exit then
254	to clen to caddr
255
256	clen to tlen
257	caddr to taddr
258	begin
259		tlen
260	while
261		taddr tlen s" , " strspn
262		\ we need to handle 3 cases for addr len pairs on stack:
263		\ addr len are 0 0 - there was no comma nor space
264		\ addr len are x 0 - the first char is either comma or space
265		\ addr len are x y.
266		2dup + 0= if
267			\ there was no comma nor space.
268			2drop
269			taddr tlen s" console" setenv
270			xt execute
271			0 to tlen
272		else dup 0= if
273			2drop
274		else
275			dup                     ( taddr' tlen' tlen' )
276			tlen swap - dup
277			0= if			\ sequence of comma and space?
278				drop
279			else
280				taddr swap s" console" setenv
281				xt execute
282			then
283			to tlen
284			to taddr
285		then then
286		tlen 0> if			\ step over separator
287			tlen 1- to tlen
288			taddr 1+ to taddr
289		then
290	repeat
291	caddr clen s" console" setenv		\ restore console setup
292	caddr free drop
293;
294
295\ Test if booted in an EFI environment
296: efi? ( -- flag )
297	s" efi-version" getenv?
298;
299
300\ determine if a word appears in a string, case-insensitive
301: contains? ( addr1 len1 addr2 len2 -- 0 | -1 )
302	2 pick 0= if 2drop 2drop true exit then
303	dup 0= if 2drop 2drop false exit then
304	begin
305		begin
306			swap dup c@ dup 32 = over 9 = or over 10 = or
307			over 13 = or over 44 = or swap drop
308		while 1+ swap 1- repeat
309		swap 2 pick 1- over <
310	while
311		2over 2over drop over compare-insensitive 0= if
312			2 pick over = if 2drop 2drop true exit then
313			2 pick tuck - -rot + swap over c@ dup 32 =
314			over 9 = or over 10 = or over 13 = or over 44 = or
315			swap drop if 2drop 2drop true exit then
316		then begin
317			swap dup c@ dup 32 = over 9 = or over 10 = or
318			over 13 = or over 44 = or swap drop
319			if false else true then 2 pick 0> and
320		while 1+ swap 1- repeat
321		swap
322	repeat
323	2drop 2drop false
324;
325
326: boot_serial? ( -- 0 | -1 )
327	s" console" getenv dup -1 <> if
328		2dup
329		s" ttya" 2swap contains?	( addr len f )
330		-rot 2dup			( f addr len addr len )
331		s" ttyb" 2swap contains?	( f addr len f )
332		-rot 2dup			( f f addr len addr len )
333		s" ttyc" 2swap contains?	( f f addr len f )
334		-rot				( f f f addr len )
335		s" ttyd" 2swap contains?	( f f addr len f )
336		or or or
337	else drop false then
338	s" boot_serial" getenv dup -1 <> if
339		swap drop 0>
340	else drop false then
341	or \ console contains tty ( or ) boot_serial
342	s" boot_multicons" getenv dup -1 <> if
343		swap drop 0>
344	else drop false then
345	or \ previous boolean ( or ) boot_multicons
346;
347
348: framebuffer? ( -- t )
349	s" console" getenv
350	s" text" compare 0<> if
351		FALSE exit
352	then
353	s" screen-width" getenv?
354;
355
356\ Private definitions
357
358vocabulary support-functions
359only forth also support-functions definitions
360
361\ Some control characters constants
362
3637 constant bell
3648 constant backspace
3659 constant tab
36610 constant lf
36713 constant <cr>
368
369\ Read buffer size
370
37180 constant read_buffer_size
372
373\ Standard suffixes
374
375: load_module_suffix		s" _load" ;
376: module_loadname_suffix	s" _name" ;
377: module_type_suffix		s" _type" ;
378: module_hash_suffix		s" _hash" ;
379: module_args_suffix		s" _flags" ;
380: module_beforeload_suffix	s" _before" ;
381: module_afterload_suffix	s" _after" ;
382: module_loaderror_suffix	s" _error" ;
383
384\ Support operators
385
386: >= < 0= ;
387: <= > 0= ;
388
389\ Assorted support functions
390
391: free-memory free if EFREE throw then ;
392
393: strget { var -- addr len } var .addr @ var .len @ ;
394
395\ assign addr len to variable.
396: strset  { addr len var -- } addr var .addr !  len var .len !  ;
397
398\ free memory and reset fields
399: strfree { var -- } var .addr @ ?dup if free-memory 0 0 var strset then ;
400
401\ free old content, make a copy of the string and assign to variable
402: string= { addr len var -- } var strfree addr len strdup var strset ;
403
404: strtype ( str -- ) strget type ;
405
406\ assign a reference to what is on the stack
407: strref { addr len var -- addr len }
408  addr var .addr ! len var .len ! addr len
409;
410
411\ unquote a string
412: unquote ( addr len -- addr len )
413  over c@ [char] " = if 2 chars - swap char+ swap then
414;
415
416\ Assignment data temporary storage
417
418string name_buffer
419string value_buffer
420
421\ Line by line file reading functions
422\
423\ exported:
424\	line_buffer
425\	end_of_file?
426\	fd
427\	read_line
428\	reset_line_reading
429
430vocabulary line-reading
431also line-reading definitions
432
433\ File data temporary storage
434
435string read_buffer
4360 value read_buffer_ptr
437
438\ File's line reading function
439
440get-current ( -- wid ) previous definitions
441
442string line_buffer
4430 value end_of_file?
444variable fd
445
446>search ( wid -- ) definitions
447
448: skip_newlines
449  begin
450    read_buffer .len @ read_buffer_ptr >
451  while
452    read_buffer .addr @ read_buffer_ptr + c@ lf = if
453      read_buffer_ptr char+ to read_buffer_ptr
454    else
455      exit
456    then
457  repeat
458;
459
460: scan_buffer  ( -- addr len )
461  read_buffer_ptr >r
462  begin
463    read_buffer .len @ r@ >
464  while
465    read_buffer .addr @ r@ + c@ lf = if
466      read_buffer .addr @ read_buffer_ptr +  ( -- addr )
467      r@ read_buffer_ptr -                   ( -- len )
468      r> to read_buffer_ptr
469      exit
470    then
471    r> char+ >r
472  repeat
473  read_buffer .addr @ read_buffer_ptr +  ( -- addr )
474  r@ read_buffer_ptr -                   ( -- len )
475  r> to read_buffer_ptr
476;
477
478: line_buffer_resize  ( len -- len )
479  dup 0= if exit then
480  >r
481  line_buffer .len @ if
482    line_buffer .addr @
483    line_buffer .len @ r@ +
484    resize if ENOMEM throw then
485  else
486    r@ allocate if ENOMEM throw then
487  then
488  line_buffer .addr !
489  r>
490;
491
492: append_to_line_buffer  ( addr len -- )
493  dup 0= if 2drop exit then
494  line_buffer strget
495  2swap strcat
496  line_buffer .len !
497  drop
498;
499
500: read_from_buffer
501  scan_buffer            ( -- addr len )
502  line_buffer_resize     ( len -- len )
503  append_to_line_buffer  ( addr len -- )
504;
505
506: refill_required?
507  read_buffer .len @ read_buffer_ptr =
508  end_of_file? 0= and
509;
510
511: refill_buffer
512  0 to read_buffer_ptr
513  read_buffer .addr @ 0= if
514    read_buffer_size allocate if ENOMEM throw then
515    read_buffer .addr !
516  then
517  fd @ read_buffer .addr @ read_buffer_size fread
518  dup -1 = if EREAD throw then
519  dup 0= if true to end_of_file? then
520  read_buffer .len !
521;
522
523get-current ( -- wid ) previous definitions >search ( wid -- )
524
525: reset_line_reading
526  0 to read_buffer_ptr
527;
528
529: read_line
530  line_buffer strfree
531  skip_newlines
532  begin
533    read_from_buffer
534    refill_required?
535  while
536    refill_buffer
537  repeat
538;
539
540only forth also support-functions definitions
541
542\ Conf file line parser:
543\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
544\            <spaces>[<comment>]
545\ <name> ::= <letter>{<letter>|<digit>|'_'|'-'}
546\ <vname> ::= <letter>{<letter>|<digit>|'_'|'-'|','}
547\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <vname>
548\ <character_set> ::= ASCII 32 to 126, except '\' and '"'
549\ <comment> ::= '#'{<anything>}
550\
551\ bootenv line parser:
552\ <line> ::= <spaces>setprop<spaces><name><spaces><value><spaces>[<comment>] |
553\            <spaces>[<comment>]
554\
555\ exported:
556\	line_pointer
557\	process_conf
558\	process_conf
559
5600 value line_pointer
561
562vocabulary file-processing
563also file-processing definitions
564
565\ parser functions
566\
567\ exported:
568\	get_assignment
569\	get_prop
570
571vocabulary parser
572also parser definitions
573
5740 value parsing_function
5750 value end_of_line
576
577: end_of_line?  line_pointer end_of_line = ;
578
579\ classifiers for various character classes in the input line
580
581: letter?
582  line_pointer c@ >r
583  r@ [char] A >=
584  r@ [char] Z <= and
585  r@ [char] a >=
586  r> [char] z <= and
587  or
588;
589
590: digit?
591  line_pointer c@ >r
592  r@ [char] - =
593  r@ [char] 0 >=
594  r> [char] 9 <= and
595  or
596;
597
598: "quote?  line_pointer c@ [char] " = ;
599
600: 'quote?  line_pointer c@ [char] ' = ;
601
602: assignment_sign?  line_pointer c@ [char] = = ;
603
604: comment?  line_pointer c@ [char] # = ;
605
606: space?  line_pointer c@ bl = line_pointer c@ tab = or ;
607
608: backslash?  line_pointer c@ [char] \ = ;
609
610: underscore?  line_pointer c@ [char] _ = ;
611
612: dot?  line_pointer c@ [char] . = ;
613
614: dash?  line_pointer c@ [char] - = ;
615
616: comma?  line_pointer c@ [char] , = ;
617
618: at?  line_pointer c@ [char] @ = ;
619
620: slash?  line_pointer c@ [char] / = ;
621
622: colon?  line_pointer c@ [char] : = ;
623
624\ manipulation of input line
625: skip_character line_pointer char+ to line_pointer ;
626
627: skip_to_end_of_line end_of_line to line_pointer ;
628
629: eat_space
630  begin
631    end_of_line? if 0 else space? then
632  while
633    skip_character
634  repeat
635;
636
637: parse_name  ( -- addr len )
638  line_pointer
639  begin
640    end_of_line? if 0 else
641      letter? digit? underscore? dot? dash? comma?
642      or or or or or
643    then
644  while
645    skip_character
646  repeat
647  line_pointer over -
648  strdup
649;
650
651: parse_value  ( -- addr len )
652  line_pointer
653  begin
654    end_of_line? if 0 else
655      letter? digit? underscore? dot? comma? dash? at? slash? colon?
656      or or or or or or or or
657    then
658  while
659    skip_character
660  repeat
661  line_pointer over -
662  strdup
663;
664
665: remove_backslashes  { addr len | addr' len' -- addr' len' }
666  len allocate if ENOMEM throw then
667  to addr'
668  addr >r
669  begin
670    addr c@ [char] \ <> if
671      addr c@ addr' len' + c!
672      len' char+ to len'
673    then
674    addr char+ to addr
675    r@ len + addr =
676  until
677  r> drop
678  addr' len'
679;
680
681: parse_quote  ( xt -- addr len )
682  >r			( R: xt )
683  line_pointer
684  skip_character
685  end_of_line? if ESYNTAX throw then
686  begin
687    r@ execute 0=
688  while
689    backslash? if
690      skip_character
691      end_of_line? if ESYNTAX throw then
692    then
693    skip_character
694    end_of_line? if ESYNTAX throw then
695  repeat
696  r> drop
697  skip_character
698  line_pointer over -
699  remove_backslashes
700;
701
702: read_name
703  parse_name		( -- addr len )
704  name_buffer strset
705;
706
707: read_value
708  "quote? if
709    ['] "quote? parse_quote		( -- addr len )
710  else
711    'quote? if
712      ['] 'quote? parse_quote		( -- addr len )
713    else
714      parse_value		( -- addr len )
715    then
716  then
717  value_buffer strset
718;
719
720: comment
721  skip_to_end_of_line
722;
723
724: white_space_4
725  eat_space
726  comment? if ['] comment to parsing_function exit then
727  end_of_line? 0= if ESYNTAX throw then
728;
729
730: variable_value
731  read_value
732  ['] white_space_4 to parsing_function
733;
734
735: white_space_3
736  eat_space
737  slash? letter? digit? "quote? 'quote? or or or or if
738    ['] variable_value to parsing_function exit
739  then
740  ESYNTAX throw
741;
742
743: assignment_sign
744  skip_character
745  ['] white_space_3 to parsing_function
746;
747
748: white_space_2
749  eat_space
750  assignment_sign? if ['] assignment_sign to parsing_function exit then
751  ESYNTAX throw
752;
753
754: variable_name
755  read_name
756  ['] white_space_2 to parsing_function
757;
758
759: white_space_1
760  eat_space
761  letter?  if ['] variable_name to parsing_function exit then
762  comment? if ['] comment to parsing_function exit then
763  end_of_line? 0= if ESYNTAX throw then
764;
765
766: prop_name
767  eat_space
768  read_name
769  ['] white_space_3 to parsing_function
770;
771
772: get_prop_cmd
773  eat_space
774  s" setprop" line_pointer over compare 0=
775  if line_pointer 7 + to line_pointer
776    ['] prop_name to parsing_function exit
777  then
778  comment? if ['] comment to parsing_function exit then
779  end_of_line? 0= if ESYNTAX throw then
780;
781
782get-current ( -- wid ) previous definitions >search ( wid -- )
783
784: get_assignment
785  line_buffer strget + to end_of_line
786  line_buffer .addr @ to line_pointer
787  ['] white_space_1 to parsing_function
788  begin
789    end_of_line? 0=
790  while
791    parsing_function execute
792  repeat
793  parsing_function ['] comment =
794  parsing_function ['] white_space_1 =
795  parsing_function ['] white_space_4 =
796  or or 0= if ESYNTAX throw then
797;
798
799: get_prop
800  line_buffer strget + to end_of_line
801  line_buffer .addr @ to line_pointer
802  ['] get_prop_cmd to parsing_function
803  begin
804    end_of_line? 0=
805  while
806    parsing_function execute
807  repeat
808  parsing_function ['] comment =
809  parsing_function ['] get_prop_cmd =
810  parsing_function ['] white_space_4 =
811  or or 0= if ESYNTAX throw then
812;
813
814only forth also support-functions also file-processing definitions
815
816\ Process line
817
818: assignment_type?  ( addr len -- flag )
819  name_buffer strget
820  compare 0=
821;
822
823: suffix_type?  ( addr len -- flag )
824  name_buffer .len @ over <= if 2drop false exit then
825  name_buffer .len @ over - name_buffer .addr @ +
826  over compare 0=
827;
828
829: loader_conf_files?  s" loader_conf_files" assignment_type?  ;
830
831: verbose_flag? s" verbose_loading" assignment_type?  ;
832
833: execute? s" exec" assignment_type?  ;
834
835: module_load? load_module_suffix suffix_type? ;
836
837: module_loadname?  module_loadname_suffix suffix_type?  ;
838
839: module_type?  module_type_suffix suffix_type?  ;
840
841: module_hash?  module_hash_suffix suffix_type?  ;
842
843: module_args?  module_args_suffix suffix_type?  ;
844
845: module_beforeload?  module_beforeload_suffix suffix_type?  ;
846
847: module_afterload?  module_afterload_suffix suffix_type?  ;
848
849: module_loaderror?  module_loaderror_suffix suffix_type?  ;
850
851\ build a 'set' statement and execute it
852: set_environment_variable
853  name_buffer .len @ value_buffer .len @ + 5 chars + \ size of result string
854  allocate if ENOMEM throw then
855  dup 0  \ start with an empty string and append the pieces
856  s" set " strcat
857  name_buffer strget strcat
858  s" =" strcat
859  value_buffer strget strcat
860  ['] evaluate catch if
861    2drop free drop
862    ESETERROR throw
863  else
864    free-memory
865  then
866;
867
868: set_conf_files
869  set_environment_variable
870  s" loader_conf_files" getenv conf_files string=
871;
872
873: append_to_module_options_list  ( addr -- )
874  module_options @ 0= if
875    dup module_options !
876    last_module_option !
877  else
878    dup last_module_option @ module.next !
879    last_module_option !
880  then
881;
882
883: set_module_name  { addr -- }	\ check leaks
884  name_buffer strget addr module.name string=
885;
886
887: yes_value?
888  value_buffer strget unquote
889  s" yes" compare-insensitive 0=
890;
891
892: find_module_option  ( -- addr | 0 ) \ return ptr to entry matching name_buffer
893  module_options @
894  begin
895    dup
896  while
897    dup module.name strget
898    name_buffer strget
899    compare 0= if exit then
900    module.next @
901  repeat
902;
903
904: new_module_option  ( -- addr )
905  sizeof module allocate if ENOMEM throw then
906  dup sizeof module erase
907  dup append_to_module_options_list
908  dup set_module_name
909;
910
911: get_module_option  ( -- addr )
912  find_module_option
913  ?dup 0= if new_module_option then
914;
915
916: set_module_flag
917  name_buffer .len @ load_module_suffix nip - name_buffer .len !
918  yes_value? get_module_option module.flag !
919;
920
921: set_module_args
922  name_buffer .len @ module_args_suffix nip - name_buffer .len !
923  value_buffer strget unquote
924  get_module_option module.args string=
925;
926
927: set_module_loadname
928  name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
929  value_buffer strget unquote
930  get_module_option module.loadname string=
931;
932
933: set_module_type
934  name_buffer .len @ module_type_suffix nip - name_buffer .len !
935  value_buffer strget unquote
936  get_module_option module.type string=
937;
938
939: set_module_hash
940  name_buffer .len @ module_hash_suffix nip - name_buffer .len !
941  value_buffer strget unquote
942  get_module_option module.hash string=
943;
944
945: set_module_beforeload
946  name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
947  value_buffer strget unquote
948  get_module_option module.beforeload string=
949;
950
951: set_module_afterload
952  name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
953  value_buffer strget unquote
954  get_module_option module.afterload string=
955;
956
957: set_module_loaderror
958  name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
959  value_buffer strget unquote
960  get_module_option module.loaderror string=
961;
962
963: set_verbose
964  yes_value? to verbose?
965;
966
967: execute_command
968  value_buffer strget unquote
969  ['] evaluate catch if EEXEC throw then
970;
971
972: process_assignment
973  name_buffer .len @ 0= if exit then
974  loader_conf_files?	if set_conf_files exit then
975  verbose_flag?		if set_verbose exit then
976  execute?		if execute_command exit then
977  module_load?		if set_module_flag exit then
978  module_loadname?	if set_module_loadname exit then
979  module_type?		if set_module_type exit then
980  module_hash?		if set_module_hash exit then
981  module_args?		if set_module_args exit then
982  module_beforeload?	if set_module_beforeload exit then
983  module_afterload?	if set_module_afterload exit then
984  module_loaderror?	if set_module_loaderror exit then
985  set_environment_variable
986;
987
988\ free_buffer  ( -- )
989\
990\ Free some pointers if needed. The code then tests for errors
991\ in freeing, and throws an exception if needed. If a pointer is
992\ not allocated, it's value (0) is used as flag.
993
994: free_buffers
995  name_buffer strfree
996  value_buffer strfree
997;
998
999\ Higher level file processing
1000
1001get-current ( -- wid ) previous definitions >search ( wid -- )
1002
1003: process_bootenv
1004  begin
1005    end_of_file? 0=
1006  while
1007    free_buffers
1008    read_line
1009    get_prop
1010    ['] process_assignment catch
1011    ['] free_buffers catch
1012    swap throw throw
1013  repeat
1014;
1015
1016: process_conf
1017  begin
1018    end_of_file? 0=
1019  while
1020    free_buffers
1021    read_line
1022    get_assignment
1023    ['] process_assignment catch
1024    ['] free_buffers catch
1025    swap throw throw
1026  repeat
1027;
1028
1029: peek_file ( addr len -- )
1030  0 to end_of_file?
1031  reset_line_reading
1032  O_RDONLY fopen fd !
1033  fd @ -1 = if EOPEN throw then
1034  free_buffers
1035  read_line
1036  get_assignment
1037  ['] process_assignment catch
1038  ['] free_buffers catch
1039  fd @ fclose
1040  swap throw throw
1041;
1042
1043only forth also support-functions definitions
1044
1045\ Interface to loading conf files
1046
1047: load_conf  ( addr len -- )
1048  0 to end_of_file?
1049  reset_line_reading
1050  O_RDONLY fopen fd !
1051  fd @ -1 = if EOPEN throw then
1052  ['] process_conf catch
1053  fd @ fclose
1054  throw
1055;
1056
1057: print_line line_buffer strtype cr ;
1058
1059: print_syntax_error
1060  line_buffer strtype cr
1061  line_buffer .addr @
1062  begin
1063    line_pointer over <>
1064  while
1065    bl emit char+
1066  repeat
1067  drop
1068  ." ^" cr
1069;
1070
1071: load_bootenv  ( addr len -- )
1072  0 to end_of_file?
1073  reset_line_reading
1074  O_RDONLY fopen fd !
1075  fd @ -1 = if EOPEN throw then
1076  ['] process_bootenv catch
1077  fd @ fclose
1078  throw
1079;
1080
1081\ Debugging support functions
1082
1083only forth definitions also support-functions
1084
1085: test-file
1086  ['] load_conf catch dup .
1087  ESYNTAX = if cr print_syntax_error then
1088;
1089
1090\ find a module name, leave addr on the stack (0 if not found)
1091: find-module ( <module> -- ptr | 0 )
1092  bl parse ( addr len )
1093  dup 0= if 2drop then	( parse did not find argument, try stack )
1094  depth 2 < if 0 exit then
1095  module_options @ >r ( store current pointer )
1096  begin
1097    r@
1098  while
1099    2dup ( addr len addr len )
1100    r@ module.name strget
1101    compare 0= if drop drop r> exit then ( found it )
1102    r> module.next @ >r
1103  repeat
1104  type ."  was not found" cr r>
1105;
1106
1107: show-nonempty ( addr len mod -- )
1108  strget dup verbose? or if
1109    2swap type type cr
1110  else
1111    drop drop drop drop
1112  then ;
1113
1114: show-one-module { addr -- addr }
1115  ." Name:        " addr module.name strtype cr
1116  s" Path:        " addr module.loadname show-nonempty
1117  s" Type:        " addr module.type show-nonempty
1118  s" Hash:        " addr module.hash show-nonempty
1119  s" Flags:       " addr module.args show-nonempty
1120  s" Before load: " addr module.beforeload show-nonempty
1121  s" After load:  " addr module.afterload show-nonempty
1122  s" Error:       " addr module.loaderror show-nonempty
1123  ." Status:      " addr module.flag @ if ." Load" else ." Don't load" then cr
1124  cr
1125  addr
1126;
1127
1128: show-module-options
1129  module_options @
1130  begin
1131    ?dup
1132  while
1133    show-one-module
1134    module.next @
1135  repeat
1136;
1137
1138: free-one-module { addr -- addr }
1139  addr module.name strfree
1140  addr module.loadname strfree
1141  addr module.type strfree
1142  addr module.hash strfree
1143  addr module.args strfree
1144  addr module.largs strfree
1145  addr module.beforeload strfree
1146  addr module.afterload strfree
1147  addr module.loaderror strfree
1148  addr
1149;
1150
1151: free-module-options
1152  module_options @
1153  begin
1154    ?dup
1155  while
1156    free-one-module
1157    dup module.next @
1158    swap free-memory
1159  repeat
1160  0 module_options !
1161  0 last_module_option !
1162;
1163
1164only forth also support-functions definitions
1165
1166\ Variables used for processing multiple conf files
1167
1168string current_file_name_ref	\ used to print the file name
1169
1170\ Indicates if any conf file was successfully read
1171
11720 value any_conf_read?
1173
1174\ loader_conf_files processing support functions
1175
1176\ true if string in addr1 is smaller than in addr2
1177: compar ( addr1 addr2 -- flag )
1178  swap			( addr2 addr1 )
1179  dup cell+		( addr2 addr1 addr )
1180  swap @		( addr2 addr len )
1181  rot			( addr len addr2 )
1182  dup cell+		( addr len addr2 addr' )
1183  swap @		( addr len addr' len' )
1184  compare -1 =
1185;
1186
1187\ insertion sort algorithm. we dont expect large amounts of data to be
1188\ sorted, so insert should be ok. compar needs to implement < operator.
1189: insert ( start end -- start )
1190  dup @ >r ( r: v )		\ v = a[i]
1191  begin
1192    2dup <			\ j>0
1193  while
1194    r@ over cell- @ compar	\ a[j-1] > v
1195  while
1196    cell-			\ j--
1197    dup @ over cell+ !		\ a[j] = a[j-1]
1198  repeat then
1199  r> swap !			\ a[j] = v
1200;
1201
1202: sort ( array len -- )
1203  1 ?do dup i cells + insert loop drop
1204;
1205
1206: opendir
1207  s" /boot/conf.d" fopendir if fd ! else
1208    EOPEN throw
1209  then
1210;
1211
1212: readdir ( addr len flag | flag )
1213  fd @ freaddir
1214;
1215
1216: closedir
1217  fd @ fclosedir
1218;
1219
1220: entries	(  -- n )	\ count directory entries
1221  ['] opendir catch		( n array )
1222  throw
1223
1224  0		( i )
1225  begin	\ count the entries
1226  readdir	( i addr len flag | i flag )
1227  dup -1 = if
1228    -ROT 2drop
1229    swap 1+ swap
1230  then
1231  0=
1232  until
1233  closedir
1234;
1235
1236\ built-in prefix directory name; it must end with /, so we don't
1237\ need to check and insert it.
1238: make_cstring	( addr len -- addr' )
1239  dup		( addr len len )
1240  s" /boot/conf.d/"	( addr len len addr' len' )
1241  rot		( addr len addr' len' len )
1242  over +	( addr len addr' len' total )	\ space for prefix+str
1243  dup cell+ 1+					\ 1+ for '\0'
1244  allocate if
1245    -1 abort" malloc failed"
1246  then
1247		( addr len addr' len' total taddr )
1248  dup rot	( addr len addr' len' taddr taddr total )
1249  swap !	( addr len addr' len' taddr )	\ store length
1250  dup >r					\ save reference
1251  cell+						\ point to string area
1252  2dup 2>r	( addr len addr' len' taddr' )	( R: taddr len' taddr' )
1253  swap move	( addr len )
1254  2r> +		( addr len taddr' )		( R: taddr )
1255  swap 1+ move					\ 1+ for '\0'
1256  r>		( taddr )
1257;
1258
1259: scan_conf_dir ( -- addr len -1 | 0 )
1260  s" currdev" getenv -1 <> if
1261    3				\ we only need first 3 chars
1262    s" net" compare 0= if
1263	s" boot.tftproot.server" getenv? if
1264	    0 exit		\ readdir does not work on tftp
1265	then
1266    then
1267  then
1268
1269  ['] entries catch if
1270    0 exit
1271  then
1272  dup 0= if exit then		\ nothing to do
1273
1274  dup cells allocate		( n array flag )	\ allocate array
1275  if 0 exit then
1276  ['] opendir catch if		( n array )
1277    free drop drop
1278    0 exit
1279  then
1280  over 0 do
1281    readdir			( n array addr len flag | n array flag )
1282    0= if -1 abort" unexpected readdir error" then	\ shouldnt happen
1283				( n array addr len )
1284    \ we have relative name, make it absolute and convert to counted string
1285    make_cstring		( n array addr )
1286    over I cells + !		( n array )
1287  loop
1288  closedir
1289  2dup swap sort
1290  \ we have now array of strings with directory entry names.
1291  \ calculate size of concatenated string
1292  over 0 swap 0 do		( n array 0 )
1293    over I cells + @		( n array total array[I] )
1294    @ + 1+			( n array total' )
1295  loop
1296  dup allocate if drop free 2drop 0 exit then
1297				( n array len addr )
1298  \ now concatenate all entries.
1299  2swap				( len addr n array )
1300  over 0 swap 0 do		( len addr n array 0 )
1301    over I cells + @		( len addr n array total array[I] )
1302    dup @ swap cell+		( len addr n array total len addr' )
1303    over			( len addr n array total len addr' len )
1304    6 pick			( len addr n array total len addr' len addr )
1305    4 pick +			( len addr n array total len addr' len addr+total )
1306    swap move +			( len addr n array total+len )
1307    3 pick			( len addr n array total addr )
1308    over + bl swap c! 1+	( len addr n array total )
1309    over I cells + @ free drop	\ free array[I]
1310  loop
1311  drop free drop drop		( len addr )
1312  swap				( addr len )
1313  -1
1314;
1315
1316: get_conf_files ( -- addr len )  \ put addr/len on stack, reset var
1317  \ ." -- starting on <" conf_files strtype ." >" cr \ debugging
1318  scan_conf_dir if		\ concatenate with conf_files
1319			( addr len )
1320    dup conf_files .len @ + 2 + allocate abort" out of memory"	( addr len addr' )
1321    dup conf_files strget	( addr len addr' caddr clen )
1322    rot swap move		( addr len addr' )
1323    \ add space
1324    dup conf_files .len @ +	( addr len addr' addr'+clen )
1325    dup bl swap c! 1+		( addr len addr' addr'' )
1326    3 pick swap			( addr len addr' addr addr'' )
1327    3 pick move			( addr len addr' )
1328    rot				( len addr' addr )
1329    free drop swap		( addr' len )
1330    conf_files .len @ + 1+	( addr len )
1331    conf_files strfree
1332  else
1333    conf_files strget 0 0 conf_files strset
1334  then
1335;
1336
1337: skip_leading_spaces  { addr len pos -- addr len pos' }
1338  begin
1339    pos len = if 0 else addr pos + c@ bl = then
1340  while
1341    pos char+ to pos
1342  repeat
1343  addr len pos
1344;
1345
1346\ return the file name at pos, or free the string if nothing left
1347: get_file_name  { addr len pos -- addr len pos' addr' len' || 0 }
1348  pos len = if
1349    addr free abort" Fatal error freeing memory"
1350    0 exit
1351  then
1352  pos >r
1353  begin
1354    \ stay in the loop until have chars and they are not blank
1355    pos len = if 0 else addr pos + c@ bl <> then
1356  while
1357    pos char+ to pos
1358  repeat
1359  addr len pos addr r@ + pos r> -
1360;
1361
1362: get_next_file  ( addr len ptr -- addr len ptr' addr' len' | 0 )
1363  skip_leading_spaces
1364  get_file_name
1365;
1366
1367: print_current_file
1368  current_file_name_ref strtype
1369;
1370
1371: process_conf_errors
1372  dup 0= if true to any_conf_read? drop exit then
1373  >r 2drop r>
1374  dup ESYNTAX = if
1375    ." Warning: syntax error on file " print_current_file cr
1376    print_syntax_error drop exit
1377  then
1378  dup ESETERROR = if
1379    ." Warning: bad definition on file " print_current_file cr
1380    print_line drop exit
1381  then
1382  dup EREAD = if
1383    ." Warning: error reading file " print_current_file cr drop exit
1384  then
1385  dup EOPEN = if
1386    verbose? if ." Warning: unable to open file " print_current_file cr then
1387    drop exit
1388  then
1389  dup EFREE = abort" Fatal error freeing memory"
1390  dup ENOMEM = abort" Out of memory"
1391  throw  \ Unknown error -- pass ahead
1392;
1393
1394\ Process loader_conf_files recursively
1395\ Interface to loader_conf_files processing
1396
1397: include_bootenv
1398  s" /boot/solaris/bootenv.rc"
1399  ['] load_bootenv catch
1400  dup 0= if drop exit then
1401  >r 2drop r>
1402  dup ESYNTAX = if
1403    ." Warning: syntax error on /boot/solaris/bootenv.rc" cr drop exit
1404  then
1405  dup EREAD = if
1406    ." Warning: error reading /boot/solaris/bootenv.rc" cr drop exit
1407  then
1408  dup EOPEN = if
1409    verbose? if ." Warning: unable to open /boot/solaris/bootenv.rc" cr then
1410    drop exit
1411  then
1412  dup EFREE = abort" Fatal error freeing memory"
1413  dup ENOMEM = abort" Out of memory"
1414  throw  \ Unknown error -- pass ahead
1415;
1416
1417: include_transient
1418  s" /boot/transient.conf" ['] load_conf catch
1419  dup 0= if drop exit then	\ no error
1420  >r 2drop r>
1421  dup ESYNTAX = if
1422    ." Warning: syntax error on file /boot/transient.conf" cr
1423    drop exit
1424  then
1425  dup ESETERROR = if
1426    ." Warning: bad definition on file /boot/transient.conf" cr
1427    drop exit
1428  then
1429  dup EREAD = if
1430    ." Warning: error reading file /boot/transient.conf" cr drop exit
1431  then
1432  dup EOPEN = if
1433    verbose? if ." Warning: unable to open file /boot/transient.conf" cr then
1434    drop exit
1435  then
1436  dup EFREE = abort" Fatal error freeing memory"
1437  dup ENOMEM = abort" Out of memory"
1438  throw  \ Unknown error -- pass ahead
1439;
1440
1441: include_conf_files
1442  get_conf_files 0	( addr len offset )
1443  begin
1444    get_next_file ?dup ( addr len 1 | 0 )
1445  while
1446    current_file_name_ref strref
1447    ['] load_conf catch
1448    process_conf_errors
1449    conf_files .addr @ if recurse then
1450  repeat
1451;
1452
1453\ Module loading functions
1454
1455\ concat two strings by allocating space
1456: concat { a1 l1 a2 l2 -- a' l' }
1457   l1 l2 + allocate if ENOMEM throw then
1458   0 a1 l1 strcat
1459   a2 l2 strcat
1460;
1461
1462\ build module argument list as: "hash= name= module.args"
1463\ if type is hash, name= will have module name without .hash suffix
1464\ will free old largs and set new.
1465
1466: build_largs { addr -- addr }
1467  addr module.largs strfree
1468  addr module.hash .len @
1469  if ( set hash= )
1470    s" hash=" addr module.hash strget concat
1471    addr module.largs strset	\ largs = "hash=" + module.hash
1472  then
1473
1474  addr module.type strget s" hash" compare 0=
1475  if ( module.type == "hash" )
1476    addr module.largs strget s"  name=" concat
1477
1478    addr module.loadname .len @
1479    if ( module.loadname != NULL )
1480      addr module.loadname strget concat
1481    else
1482      addr module.name strget concat
1483    then
1484
1485    addr module.largs strfree
1486    addr module.largs strset	\ largs = largs + name
1487
1488    \ last thing to do is to strip off ".hash" suffix
1489    addr module.largs strget [char] . strchr
1490    dup if ( strchr module.largs '.' )
1491      s" .hash" compare 0=
1492      if ( it is ".hash" )
1493        addr module.largs .len @ 5 -
1494        addr module.largs .len !
1495      then
1496    else
1497      2drop
1498    then
1499  then
1500  \ and now add up the module.args
1501  addr module.largs strget s"  " concat
1502  addr module.args strget concat
1503  addr module.largs strfree
1504  addr module.largs strset
1505  addr
1506;
1507
1508: load_parameters  { addr -- addr addrN lenN ... addr1 len1 N }
1509  addr build_largs
1510  addr module.largs strget
1511  addr module.loadname .len @ if
1512    addr module.loadname strget
1513  else
1514    addr module.name strget
1515  then
1516  addr module.type .len @ if
1517    addr module.type strget
1518    s" -t "
1519    4 ( -t type name flags )
1520  else
1521    2 ( name flags )
1522  then
1523;
1524
1525: before_load  ( addr -- addr )
1526  dup module.beforeload .len @ if
1527    dup module.beforeload strget
1528    ['] evaluate catch if EBEFORELOAD throw then
1529  then
1530;
1531
1532: after_load  ( addr -- addr )
1533  dup module.afterload .len @ if
1534    dup module.afterload strget
1535    ['] evaluate catch if EAFTERLOAD throw then
1536  then
1537;
1538
1539: load_error  ( addr -- addr )
1540  dup module.loaderror .len @ if
1541    dup module.loaderror strget
1542    evaluate  \ This we do not intercept so it can throw errors
1543  then
1544;
1545
1546: pre_load_message  ( addr -- addr )
1547  verbose? if
1548    dup module.name strtype
1549    ." ..."
1550  then
1551;
1552
1553: load_error_message verbose? if ." failed!" cr then ;
1554
1555: load_successful_message verbose? if ." ok" cr then ;
1556
1557: load_module
1558  load_parameters load
1559;
1560
1561: process_module  ( addr -- addr )
1562  pre_load_message
1563  before_load
1564  begin
1565    ['] load_module catch if
1566      dup module.loaderror .len @ if
1567        load_error			\ Command should return a flag!
1568      else
1569        load_error_message true		\ Do not retry
1570      then
1571    else
1572      after_load
1573      load_successful_message true	\ Successful, do not retry
1574    then
1575  until
1576;
1577
1578: process_module_errors  ( addr ior -- )
1579  dup EBEFORELOAD = if
1580    drop
1581    ." Module "
1582    dup module.name strtype
1583    dup module.loadname .len @ if
1584      ." (" dup module.loadname strtype ." )"
1585    then
1586    cr
1587    ." Error executing "
1588    dup module.beforeload strtype cr	\ XXX there was a typo here
1589    abort
1590  then
1591
1592  dup EAFTERLOAD = if
1593    drop
1594    ." Module "
1595    dup module.name .addr @ over module.name .len @ type
1596    dup module.loadname .len @ if
1597      ." (" dup module.loadname strtype ." )"
1598    then
1599    cr
1600    ." Error executing "
1601    dup module.afterload strtype cr
1602    abort
1603  then
1604
1605  throw  \ Don't know what it is all about -- pass ahead
1606;
1607
1608\ Module loading interface
1609
1610\ scan the list of modules, load enabled ones.
1611: load_modules  ( -- ) ( throws: abort & user-defined )
1612  module_options @	( list_head )
1613  begin
1614    ?dup
1615  while
1616    dup module.flag @ if
1617      ['] process_module catch
1618      process_module_errors
1619    then
1620    module.next @
1621  repeat
1622;
1623
1624\ h00h00 magic used to try loading either a kernel with a given name,
1625\ or a kernel with the default name in a directory of a given name
1626\ (the pain!)
1627
1628: bootpath s" /platform/" ;
1629: modulepath s" module_path" ;
1630
1631\ Functions used to save and restore module_path's value.
1632: saveenv ( addr len | -1 -- addr' len | 0 -1 )
1633  dup -1 = if 0 swap exit then
1634  strdup
1635;
1636: freeenv ( addr len | 0 -1 )
1637  -1 = if drop else free abort" Freeing error" then
1638;
1639: restoreenv  ( addr len | 0 -1 -- )
1640  dup -1 = if ( it wasn't set )
1641    2drop
1642    modulepath unsetenv
1643  else
1644    over >r
1645    modulepath setenv
1646    r> free abort" Freeing error"
1647  then
1648;
1649
1650: clip_args   \ Drop second string if only one argument is passed
1651  1 = if
1652    2swap 2drop
1653    1
1654  else
1655    2
1656  then
1657;
1658
1659also builtins
1660
1661\ Parse filename from a semicolon-separated list
1662
1663: parse-; ( addr len -- addr' len-x addr x )
1664  over 0 2swap			( addr 0 addr len )
1665  begin
1666    dup 0 <>			( addr 0 addr len )
1667  while
1668    over c@ [char] ; <>		( addr 0 addr len flag )
1669  while
1670    1- swap 1+ swap
1671    2swap 1+ 2swap
1672  repeat then
1673  dup 0 <> if
1674    1- swap 1+ swap
1675  then
1676  2swap
1677;
1678
1679\ Try loading one of multiple kernels specified
1680
1681: try_multiple_kernels ( addr len addr' len' args -- flag )
1682  >r
1683  begin
1684    parse-; 2>r
1685    2over 2r>
1686    r@ clip_args
1687    s" DEBUG" getenv? if
1688      s" echo Module_path: ${module_path}" evaluate
1689      ." Kernel     : " >r 2dup type r> cr
1690      dup 2 = if ." Flags      : " >r 2over type r> cr then
1691    then
1692    \ if it's xen, the xen kernel is loaded, unix needs to be loaded as module
1693    s" xen_kernel" getenv -1 <> if
1694      drop			\ drop address from getenv
1695      >r			\ argument count to R
1696      s" kernel" s" -t "	\ push 2 strings into the stack
1697      r> 2 +			\ increment argument count
1698    then
1699
1700    1 ['] load catch dup if
1701      ( addr0 len0 addr1 len1 ... args 1 error )
1702      >r			\ error code to R
1703      drop			\ drop 1
1704      0 do 2drop loop		\ drop addr len pairs
1705      r>			\ set flag for while
1706    then
1707  while
1708    dup 0=
1709  until
1710    1 >r \ Failure
1711  else
1712    0 >r \ Success
1713  then
1714  2drop 2drop
1715  r>
1716  r> drop
1717;
1718
1719\ Try to load a kernel; the kernel name is taken from one of
1720\ the following lists, as ordered:
1721\
1722\   1. The "bootfile" environment variable
1723\   2. The "kernel" environment variable
1724\
1725\ Flags are passed, if available. If not, dummy values must be given.
1726\
1727\ The kernel gets loaded from the current module_path.
1728
1729: load_a_kernel ( flags len 1 | x x 0 -- flag )
1730  local args
1731  2local flags
1732  0 0 2local kernel
1733  end-locals
1734
1735  \ Check if a default kernel name exists at all, exits if not
1736  s" bootfile" getenv dup -1 <> if
1737    to kernel
1738    flags kernel args 1+ try_multiple_kernels
1739    dup 0= if exit then
1740  then
1741  drop
1742
1743  s" kernel" getenv dup -1 <> if
1744    to kernel
1745  else
1746    drop
1747    1 exit \ Failure
1748  then
1749
1750  \ Try all default kernel names
1751  flags kernel args 1+ try_multiple_kernels
1752;
1753
1754\ Try to load a kernel; the kernel name is taken from one of
1755\ the following lists, as ordered:
1756\
1757\   1. The "bootfile" environment variable
1758\   2. The "kernel" environment variable
1759\
1760\ Flags are passed, if provided.
1761\
1762\ The kernel will be loaded from a directory computed from the
1763\ path given. Two directories will be tried in the following order:
1764\
1765\   1. /boot/path
1766\   2. path
1767\
1768\ The module_path variable is overridden if load is successful, by
1769\ prepending the successful path.
1770
1771: load_from_directory ( path len 1 | flags len' path len 2 -- flag )
1772  local args
1773  2local path
1774  args 1 = if 0 0 then
1775  2local flags
1776  0 0 2local oldmodulepath \ like a string
1777  0 0 2local newmodulepath \ like a string
1778  end-locals
1779
1780  \ Set the environment variable module_path, and try loading
1781  \ the kernel again.
1782  modulepath getenv saveenv to oldmodulepath
1783
1784  \ Try prepending /boot/ first
1785  bootpath nip path nip +	\ total length
1786  oldmodulepath nip dup -1 = if
1787    drop
1788  else
1789    1+ +			\ add oldpath -- XXX why the 1+ ?
1790  then
1791  allocate if ( out of memory ) 1 exit then \ XXX throw ?
1792
1793  0
1794  bootpath strcat
1795  path strcat
1796  2dup to newmodulepath
1797  modulepath setenv
1798
1799  \ Try all default kernel names
1800  flags args 1- load_a_kernel
1801  0= if ( success )
1802    oldmodulepath nip -1 <> if
1803      newmodulepath s" ;" strcat
1804      oldmodulepath strcat
1805      modulepath setenv
1806      newmodulepath drop free-memory
1807      oldmodulepath drop free-memory
1808    then
1809    0 exit
1810  then
1811
1812  \ Well, try without the prepended /boot/
1813  path newmodulepath drop swap move
1814  newmodulepath drop path nip
1815  2dup to newmodulepath
1816  modulepath setenv
1817
1818  \ Try all default kernel names
1819  flags args 1- load_a_kernel
1820  if ( failed once more )
1821    oldmodulepath restoreenv
1822    newmodulepath drop free-memory
1823    1
1824  else
1825    oldmodulepath nip -1 <> if
1826      newmodulepath s" ;" strcat
1827      oldmodulepath strcat
1828      modulepath setenv
1829      newmodulepath drop free-memory
1830      oldmodulepath drop free-memory
1831    then
1832    0
1833  then
1834;
1835
1836\ Try to load a kernel; the kernel name is taken from one of
1837\ the following lists, as ordered:
1838\
1839\   1. The "bootfile" environment variable
1840\   2. The "kernel" environment variable
1841\   3. The "path" argument
1842\
1843\ Flags are passed, if provided.
1844\
1845\ The kernel will be loaded from a directory computed from the
1846\ path given. Two directories will be tried in the following order:
1847\
1848\   1. /boot/path
1849\   2. path
1850\
1851\ Unless "path" is meant to be kernel name itself. In that case, it
1852\ will first be tried as a full path, and, next, search on the
1853\ directories pointed by module_path.
1854\
1855\ The module_path variable is overridden if load is successful, by
1856\ prepending the successful path.
1857
1858: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag )
1859  local args
1860  2local path
1861  args 1 = if 0 0 then
1862  2local flags
1863  end-locals
1864
1865  \ First, assume path is an absolute path to a directory
1866  flags path args clip_args load_from_directory
1867  dup 0= if exit else drop then
1868
1869  \ Next, assume path points to the kernel
1870  flags path args try_multiple_kernels
1871;
1872
1873: initialize  ( addr len -- )
1874  strdup conf_files strset
1875;
1876
1877: boot-args ( -- addr len 1 | 0 )
1878  s" boot-args" getenv
1879  dup -1 = if drop 0 else 1 then
1880;
1881
1882: standard_kernel_search  ( flags 1 | 0 -- flag )
1883  local args
1884  args 0= if 0 0 then
1885  2local flags
1886  s" kernel" getenv
1887  dup -1 = if 0 swap then
1888  2local path
1889  end-locals
1890
1891  path nip -1 = if ( there isn't a "kernel" environment variable )
1892    flags args load_a_kernel
1893  else
1894    flags path args 1+ clip_args load_directory_or_file
1895  then
1896;
1897
1898: load_kernel  ( -- ) ( throws: abort )
1899  s" xen_kernel" getenv -1 = if
1900    boot-args standard_kernel_search
1901    abort" Unable to load a kernel!"
1902    exit
1903  then
1904
1905  drop
1906  \ we have loaded the xen kernel, load unix as module
1907  s" bootfile" getenv dup -1 <> if
1908    s" kernel" s" -t " 3 1 load
1909  then
1910  abort" Unable to load a kernel!"
1911;
1912
1913: load_xen ( -- )
1914  s" xen_kernel" getenv dup -1 <> if
1915    1 1 load ( c-addr/u flag N -- flag )
1916  else
1917    drop
1918    0 ( -1 -- flag )
1919  then
1920;
1921
1922: load_xen_throw ( -- ) ( throws: abort )
1923  load_xen
1924  abort" Unable to load Xen!"
1925;
1926
1927: set_defaultoptions  ( -- )
1928  s" boot-args" getenv dup -1 = if
1929    drop
1930  else
1931    s" temp_options" setenv
1932  then
1933;
1934
1935\ pick the i-th argument, i starts at 0
1936: argv[]  ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
1937  2dup = if 0 0 exit then	\ out of range
1938  dup >r
1939  1+ 2* ( skip N and ui )
1940  pick
1941  r>
1942  1+ 2* ( skip N and ai )
1943  pick
1944;
1945
1946: drop_args  ( aN uN ... a1 u1 N -- )
1947  0 ?do 2drop loop
1948;
1949
1950: argc
1951  dup
1952;
1953
1954: queue_argv  ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 )
1955  >r
1956  over 2* 1+ -roll
1957  r>
1958  over 2* 1+ -roll
1959  1+
1960;
1961
1962: unqueue_argv  ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 )
1963  1- -rot
1964;
1965
1966\ compute the length of the buffer including the spaces between words
1967: strlen(argv) ( aN uN .. a1 u1 N -- aN uN .. a1 u1 N len )
1968  dup 0= if 0 exit then
1969  0 >r	\ Size
1970  0 >r	\ Index
1971  begin
1972    argc r@ <>
1973  while
1974    r@ argv[]
1975    nip
1976    r> r> rot + 1+
1977    >r 1+ >r
1978  repeat
1979  r> drop
1980  r>
1981;
1982
1983: concat_argv  ( aN uN ... a1 u1 N -- a u )
1984  strlen(argv) allocate if ENOMEM throw then
1985  0 2>r ( save addr 0 on return stack )
1986
1987  begin
1988    dup
1989  while
1990    unqueue_argv ( ... N a1 u1 )
1991    2r> 2swap	 ( old a1 u1 )
1992    strcat
1993    s"  " strcat ( append one space ) \ XXX this gives a trailing space
1994    2>r		( store string on the result stack )
1995  repeat
1996  drop_args
1997  2r>
1998;
1999
2000: set_tempoptions  ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
2001  \ Save the first argument, if it exists and is not a flag
2002  argc if
2003    0 argv[] drop c@ [char] - <> if
2004      unqueue_argv 2>r  \ Filename
2005      1 >r		\ Filename present
2006    else
2007      0 >r		\ Filename not present
2008    then
2009  else
2010    0 >r		\ Filename not present
2011  then
2012
2013  \ If there are other arguments, assume they are flags
2014  ?dup if
2015    concat_argv
2016    2dup s" temp_options" setenv
2017    drop free if EFREE throw then
2018  else
2019    set_defaultoptions
2020  then
2021
2022  \ Bring back the filename, if one was provided
2023  r> if 2r> 1 else 0 then
2024;
2025
2026: get_arguments ( -- addrN lenN ... addr1 len1 N )
2027  0
2028  begin
2029    \ Get next word on the command line
2030    parse-word
2031  ?dup while
2032    queue_argv
2033  repeat
2034  drop ( empty string )
2035;
2036
2037: load_kernel_and_modules  ( args -- flag )
2038  set_tempoptions
2039  argc >r
2040  s" temp_options" getenv dup -1 <> if
2041    queue_argv
2042  else
2043    drop
2044  then
2045  load_xen
2046  ?dup 0= if ( success )
2047    r> if ( a path was passed )
2048      load_directory_or_file
2049    else
2050      standard_kernel_search
2051    then
2052    ?dup 0= if ['] load_modules catch then
2053  then
2054;
2055
2056only forth definitions
2057