| support.4th (50477) | support.4th (53672) |
|---|---|
| 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. --- 8 unchanged lines hidden (view full) --- 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\ | 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. --- 8 unchanged lines hidden (view full) --- 17\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 18\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 19\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 20\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 21\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 22\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 23\ SUCH DAMAGE. 24\ |
| 25\ $FreeBSD: head/sys/boot/forth/support.4th 50477 1999-08-28 01:08:13Z peter $ | 25\ $FreeBSD: head/sys/boot/forth/support.4th 53672 1999-11-24 17:56:40Z dcs $ |
| 26 27\ Loader.rc support functions: 28\ 29\ initialize_support ( -- ) initialize global variables 30\ initialize ( addr len -- ) as above, plus load_conf_files 31\ load_conf ( addr len -- ) load conf file given 32\ include_conf_files ( -- ) load all conf files in load_conf_files 33\ print_syntax_error ( -- ) print line and marker of where a syntax --- 16 unchanged lines hidden (view full) --- 50\ string module.beforeload command to be executed before load 51\ string module.afterload command to be executed after load 52\ string module.loaderror command to be executed if load fails 53\ cell module.next list chain 54\ 55\ Exported global variables; 56\ 57\ string conf_files configuration files to be loaded | 26 27\ Loader.rc support functions: 28\ 29\ initialize_support ( -- ) initialize global variables 30\ initialize ( addr len -- ) as above, plus load_conf_files 31\ load_conf ( addr len -- ) load conf file given 32\ include_conf_files ( -- ) load all conf files in load_conf_files 33\ print_syntax_error ( -- ) print line and marker of where a syntax --- 16 unchanged lines hidden (view full) --- 50\ string module.beforeload command to be executed before load 51\ string module.afterload command to be executed after load 52\ string module.loaderror command to be executed if load fails 53\ cell module.next list chain 54\ 55\ Exported global variables; 56\ 57\ string conf_files configuration files to be loaded |
| 58\ string password password |
|
| 58\ cell modules_options pointer to first module information 59\ value verbose? indicates if user wants a verbose loading 60\ value any_conf_read? indicates if a conf file was succesfully read 61\ 62\ Other exported words: 63\ 64\ strdup ( addr len -- addr' len) similar to strdup(3) 65\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3) --- 41 unchanged lines hidden (view full) --- 107 sizeof string member: module.afterload 108 sizeof string member: module.loaderror 109 ptr module.next 110;structure 111 112\ Global variables 113 114string conf_files | 59\ cell modules_options pointer to first module information 60\ value verbose? indicates if user wants a verbose loading 61\ value any_conf_read? indicates if a conf file was succesfully read 62\ 63\ Other exported words: 64\ 65\ strdup ( addr len -- addr' len) similar to strdup(3) 66\ strcat ( addr len addr' len' -- addr len+len' ) similar to strcat(3) --- 41 unchanged lines hidden (view full) --- 108 sizeof string member: module.afterload 109 sizeof string member: module.loaderror 110 ptr module.next 111;structure 112 113\ Global variables 114 115string conf_files |
| 116string password |
|
| 115create module_options sizeof module.next allot 116create last_module_option sizeof module.next allot 1170 value verbose? 118 119\ Support string functions 120 121: strdup ( addr len -- addr' len ) 122 >r r@ allocate if out_of_memory throw then --- 8 unchanged lines hidden (view full) --- 131 132: s' 133 [char] ' parse 134 state @ if 135 postpone sliteral 136 then 137; immediate 138 | 117create module_options sizeof module.next allot 118create last_module_option sizeof module.next allot 1190 value verbose? 120 121\ Support string functions 122 123: strdup ( addr len -- addr' len ) 124 >r r@ allocate if out_of_memory throw then --- 8 unchanged lines hidden (view full) --- 133 134: s' 135 [char] ' parse 136 state @ if 137 postpone sliteral 138 then 139; immediate 140 |
| 141\ How come ficl doesn't have again? 142 143: again false postpone literal postpone until ; immediate 144 |
|
| 139\ Private definitions 140 141vocabulary support-functions 142only forth also support-functions definitions 143 144\ Some control characters constants 145 | 145\ Private definitions 146 147vocabulary support-functions 148only forth also support-functions definitions 149 150\ Some control characters constants 151 |
| 1527 constant bell 1538 constant backspace |
|
| 1469 constant tab 14710 constant lf | 1549 constant tab 15510 constant lf |
| 15613 constant <cr> |
|
| 148 149\ Read buffer size 150 15180 constant read_buffer_size 152 153\ Standard suffixes 154 155: load_module_suffix s" _load" ; --- 344 unchanged lines hidden (view full) --- 500: verbose_flag? 501 s" verbose_loading" assignment_type? 502; 503 504: execute? 505 s" exec" assignment_type? 506; 507 | 157 158\ Read buffer size 159 16080 constant read_buffer_size 161 162\ Standard suffixes 163 164: load_module_suffix s" _load" ; --- 344 unchanged lines hidden (view full) --- 509: verbose_flag? 510 s" verbose_loading" assignment_type? 511; 512 513: execute? 514 s" exec" assignment_type? 515; 516 |
| 517: password? 518 s" password" assignment_type? 519; 520 |
|
| 508: module_load? 509 load_module_suffix suffix_type? 510; 511 512: module_loadname? 513 module_loadname_suffix suffix_type? 514; 515 --- 182 unchanged lines hidden (view full) --- 698 699: set_verbose 700 yes_value? to verbose? 701; 702 703: execute_command 704 value_buffer .addr @ value_buffer .len @ 705 over c@ [char] " = if | 521: module_load? 522 load_module_suffix suffix_type? 523; 524 525: module_loadname? 526 module_loadname_suffix suffix_type? 527; 528 --- 182 unchanged lines hidden (view full) --- 711 712: set_verbose 713 yes_value? to verbose? 714; 715 716: execute_command 717 value_buffer .addr @ value_buffer .len @ 718 over c@ [char] " = if |
| 706 2 chars - swap char+ swap | 719 2 - swap char+ swap |
| 707 then 708 ['] evaluate catch if exec_error throw then 709; 710 | 720 then 721 ['] evaluate catch if exec_error throw then 722; 723 |
| 724: set_password 725 password .addr @ ?dup if free if free_error throw then then 726 value_buffer .addr @ c@ [char] " = if 727 value_buffer .addr @ char+ value_buffer .len @ 2 - strdup 728 value_buffer .addr @ free if free_error throw then 729 else 730 value_buffer .addr @ value_buffer .len @ 731 then 732 password .len ! password .addr ! 733 0 value_buffer .addr ! 734; 735 |
|
| 711: process_assignment 712 name_buffer .len @ 0= if exit then 713 loader_conf_files? if set_conf_files exit then 714 verbose_flag? if set_verbose exit then 715 execute? if execute_command exit then | 736: process_assignment 737 name_buffer .len @ 0= if exit then 738 loader_conf_files? if set_conf_files exit then 739 verbose_flag? if set_verbose exit then 740 execute? if execute_command exit then |
| 741 password? if set_password exit then |
|
| 716 module_load? if set_module_flag exit then 717 module_loadname? if set_module_loadname exit then 718 module_type? if set_module_type exit then 719 module_args? if set_module_args exit then 720 module_beforeload? if set_module_beforeload exit then 721 module_afterload? if set_module_afterload exit then 722 module_loaderror? if set_module_loaderror exit then 723 set_environment_variable 724; 725 | 742 module_load? if set_module_flag exit then 743 module_loadname? if set_module_loadname exit then 744 module_type? if set_module_type exit then 745 module_args? if set_module_args exit then 746 module_beforeload? if set_module_beforeload exit then 747 module_afterload? if set_module_afterload exit then 748 module_loaderror? if set_module_loaderror exit then 749 set_environment_variable 750; 751 |
| 752\ free_buffer ( -- ) 753\ 754\ Free some pointers if needed. The code then tests for errors 755\ in freeing, and throws an exception if needed. If a pointer is 756\ not allocated, it's value (0) is used as flag. 757 |
|
| 726: free_buffers 727 line_buffer .addr @ dup if free then 728 name_buffer .addr @ dup if free then 729 value_buffer .addr @ dup if free then 730 or or if free_error throw then 731; 732 733: reset_assignment_buffers --- 39 unchanged lines hidden (view full) --- 773 ['] process_conf catch 774 fd @ fclose 775 throw 776; 777 778: initialize_support 779 0 read_buffer .addr ! 780 0 conf_files .addr ! | 758: free_buffers 759 line_buffer .addr @ dup if free then 760 name_buffer .addr @ dup if free then 761 value_buffer .addr @ dup if free then 762 or or if free_error throw then 763; 764 765: reset_assignment_buffers --- 39 unchanged lines hidden (view full) --- 805 ['] process_conf catch 806 fd @ fclose 807 throw 808; 809 810: initialize_support 811 0 read_buffer .addr ! 812 0 conf_files .addr ! |
| 813 0 password .addr ! |
|
| 781 0 module_options ! 782 0 last_module_option ! 783 0 to verbose? 784; 785 786: print_line 787 line_buffer .addr @ line_buffer .len @ type cr 788; --- 57 unchanged lines hidden (view full) --- 846: get_conf_files 847 conf_files .addr @ conf_files .len @ strdup 848; 849 850: recurse_on_conf_files? 851 current_conf_files @ conf_files .addr @ <> 852; 853 | 814 0 module_options ! 815 0 last_module_option ! 816 0 to verbose? 817; 818 819: print_line 820 line_buffer .addr @ line_buffer .len @ type cr 821; --- 57 unchanged lines hidden (view full) --- 879: get_conf_files 880 conf_files .addr @ conf_files .len @ strdup 881; 882 883: recurse_on_conf_files? 884 current_conf_files @ conf_files .addr @ <> 885; 886 |
| 854: skip_leading_spaces { addr len ptr -- addr len ptr' } | 887: skip_leading_spaces { addr len pos -- addr len pos' } |
| 855 begin | 888 begin |
| 856 ptr len = if addr len ptr exit then 857 addr ptr + c@ bl = | 889 pos len = if addr len pos exit then 890 addr pos + c@ bl = |
| 858 while | 891 while |
| 859 ptr char+ to ptr | 892 pos char+ to pos |
| 860 repeat | 893 repeat |
| 861 addr len ptr | 894 addr len pos |
| 862; 863 | 895; 896 |
| 864: get_file_name { addr len ptr -- addr len ptr' addr' len' || 0 } 865 ptr len = if | 897: get_file_name { addr len pos -- addr len pos' addr' len' || 0 } 898 pos len = if |
| 866 addr free abort" Fatal error freeing memory" 867 0 exit 868 then | 899 addr free abort" Fatal error freeing memory" 900 0 exit 901 then |
| 869 ptr >r | 902 pos >r |
| 870 begin | 903 begin |
| 871 addr ptr + c@ bl <> | 904 addr pos + c@ bl <> |
| 872 while | 905 while |
| 873 ptr char+ to ptr 874 ptr len = if 875 addr len ptr addr r@ + ptr r> - exit | 906 pos char+ to pos 907 pos len = if 908 addr len pos addr r@ + pos r> - exit |
| 876 then 877 repeat | 909 then 910 repeat |
| 878 addr len ptr addr r@ + ptr r> - | 911 addr len pos addr r@ + pos r> - |
| 879; 880 881: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 882 skip_leading_spaces 883 get_file_name 884; 885 886: set_current_file_name --- 173 unchanged lines hidden (view full) --- 1060 strdup conf_files .len ! conf_files .addr ! 1061; 1062 1063: load_kernel ( -- ) ( throws: abort ) 1064 s" load ${kernel} ${kernel_options}" ['] evaluate catch 1065 if s" echo Unable to load kernel: ${kernel_name}" evaluate abort then 1066; 1067 | 912; 913 914: get_next_file ( addr len ptr -- addr len ptr' addr' len' | 0 ) 915 skip_leading_spaces 916 get_file_name 917; 918 919: set_current_file_name --- 173 unchanged lines hidden (view full) --- 1093 strdup conf_files .len ! conf_files .addr ! 1094; 1095 1096: load_kernel ( -- ) ( throws: abort ) 1097 s" load ${kernel} ${kernel_options}" ['] evaluate catch 1098 if s" echo Unable to load kernel: ${kernel_name}" evaluate abort then 1099; 1100 |
| 1101: read-password { size | buf len -- } 1102 size allocate if out_of_memory throw then 1103 to buf 1104 0 to len 1105 begin 1106 key 1107 dup backspace = if 1108 drop 1109 len if 1110 backspace emit bl emit backspace emit 1111 len 1 - to len 1112 else 1113 bell emit 1114 then 1115 else 1116 dup <cr> = if cr drop buf len exit then 1117 [char] * emit 1118 len size < if 1119 buf len chars + c! 1120 else 1121 drop 1122 then 1123 len 1+ to len 1124 then 1125 again 1126; 1127 |
|
| 1068\ Go back to straight forth vocabulary 1069 1070only forth also definitions 1071 | 1128\ Go back to straight forth vocabulary 1129 1130only forth also definitions 1131 |