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 65883 2000-09-15 08:05:52Z dcs $
26
27\ Loader.rc support functions:
28\
29\ initialize_support ( -- ) initialize global variables
30\ initialize ( addr len -- ) as above, plus load_conf_files
31\ load_conf ( addr len -- ) load conf file given
32\ include_conf_files ( -- ) load all conf files in load_conf_files
33\ print_syntax_error ( -- ) print line and marker of where a syntax
--- 194 unchanged lines hidden (view full) ---
228 [char] ' parse
229 state @ if
230 postpone sliteral
231 then
232; immediate
233
234: 2>r postpone >r postpone >r ; immediate
235: 2r> postpone r> postpone r> ; immediate
236: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate
237
238\ Private definitions
239
240vocabulary support-functions
241only forth also support-functions definitions
242
243\ Some control characters constants
244
--- 1050 unchanged lines hidden (view full) ---
1295;
1296
1297\ Try to load a kernel; the kernel name is taken from one of
1298\ the following lists, as ordered:
1299\
1300\ 1. The "bootfile" environment variable
1301\ 2. The "kernel" environment variable
1302\
1303\ Flags are passed, if available.
1304\
1305\ The kernel gets loaded from the current module_path.
1306
1307: load_a_kernel ( flags len 1 | 0 -- flag )
1308 local args
1309 args 0= if 0 0 then
1310 2local flags
1311 0 0 2local kernel
1312 end-locals
1313
1314 \ Check if a default kernel name exists at all, exits if not
1315 s" bootfile" getenv dup -1 <> if
1316 to kernel
1317 flags kernel args 1+ try_multiple_kernels
1318 dup 0= if exit then
1319 then
1320 drop
1321
1322 s" kernel" getenv dup -1 <> if
1323 to kernel
1324 else
1325 drop
1326 1 exit \ Failure
1327 then
1328
1329 \ Try all default kernel names
1330 flags kernel args 1+ try_multiple_kernels
1331;
1332
1333\ Try to load a kernel; the kernel name is taken from one of
1334\ the following lists, as ordered:
1335\
1336\ 1. The "bootfile" environment variable
1337\ 2. The "kernel" environment variable
1338\
--- 35 unchanged lines hidden (view full) ---
1374
1375 0
1376 bootpath strcat
1377 path strcat
1378 2dup to newmodulepath
1379 modulepath setenv
1380
1381 \ Try all default kernel names
1382 args 2 = if flags 1 else 0 then
1383 load_a_kernel
1384 0= if ( success )
1385 oldmodulepath nip -1 <> if
1386 newmodulepath s" ;" strcat
1387 oldmodulepath strcat
1388 modulepath setenv
1389 newmodulepath drop free-memory
1390 oldmodulepath drop free-memory
1391 then
1392 0 exit
1393 then
1394
1395 \ Well, try without the prepended /boot/
1396 path newmodulepath drop swap move
1397 newmodulepath drop path nip
1398 2dup to newmodulepath
1399 modulepath setenv
1400
1401 \ Try all default kernel names
1402 args 2 = if flags 1 else 0 then
1403 load_a_kernel
1404 if ( failed once more )
1405 oldmodulepath restoreenv
1406 newmodulepath drop free-memory
1407 1
1408 else
1409 oldmodulepath nip -1 <> if
1410 newmodulepath s" ;" strcat
1411 oldmodulepath strcat
--- 39 unchanged lines hidden (view full) ---
1451 dup 0= if exit else drop then
1452
1453 \ Next, assume path points to the kernel
1454 flags path args try_multiple_kernels
1455;
1456
1457: load_kernel_and_modules ( flags len path len' 2 | path len' 1 -- flag )
1458 load_directory_or_file
1459 ?dup 0= if ['] load_modules catch then
1460;
1461
1462: initialize ( addr len -- )
1463 strdup conf_files .len ! conf_files .addr !
1464;
1465
1466: kernel_options ( -- addr len 1 | 0 )
1467 s" kernel_options" getenv
1468 dup -1 = if drop 0 else 1 then
1469;
1470
1471: kernel_and_options ( a u 1 | 0 -- a u a' u' 2 | a' u' 1 )
1472 kernel_options
1473 s" kernel" getenv
1474 rot 1+
1475;
1476
1477: load_kernel ( -- ) ( throws: abort )
1478 s" kernel" getenv
1479 dup -1 = if ( there isn't a "kernel" environment variable, try bootfile )
1480 drop
1481 kernel_options load_a_kernel
1482 else ( try finding a kernel using ${kernel} in various ways )
1483 kernel_options >r 2swap r> clip_args load_from_directory
1484 dup if
1485 drop
1486 kernel_and_options try_multiple_kernels
1487 then
1488 then
1489 abort" Unable to load a kernel!"
1490;
1491
1492: set-defaultoptions ( -- )
1493 s" kernel_options" getenv dup -1 = if
1494 drop
1495 else
1496 s" temp_options" setenv
1497 then
1498;
1499
1500: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
1501 2dup = if 0 0 exit then
1502 dup >r
1503 1+ 2* ( skip N and ui )
1504 pick
1505 r>
1506 1+ 2* ( skip N and ai )
1507 pick
1508;
1509
1510: drop-args ( aN uN ... a1 u1 N -- )
1511 0 ?do 2drop loop
1512;
1513
1514: argc
1515 dup
1516;
1517
1518: queue-argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 )
1519 >r
1520 over 2* 1+ -roll
1521 r>
1522 over 2* 1+ -roll
1523 1+
1524;
1525
1526: unqueue-argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 )
1527 1- -rot
1528;
1529
1530: strlen(argv)
1531 dup 0= if 0 exit then
1532 0 >r \ Size
1533 0 >r \ Index
1534 begin
1535 argc r@ <>
1536 while
1537 r@ argv[]
1538 nip
1539 r> r> rot + 1+
1540 >r 1+ >r
1541 repeat
1542 r> drop
1543 r>
1544;
1545
1546: concat-argv ( aN uN ... a1 u1 N -- a u )
1547 strlen(argv) allocate if out_of_memory throw then
1548 0 2>r
1549
1550 begin
1551 argc
1552 while
1553 unqueue-argv
1554 2r> 2swap
1555 strcat
1556 s" " strcat
1557 2>r
1558 repeat
1559 drop-args
1560 2r>
1561;
1562
1563: set-tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
1564 \ Save the first argument, if it exists and is not a flag
1565 argc if
1566 0 argv[] drop c@ [char] - <> if
1567 unqueue-argv 2>r \ Filename
1568 1 >r \ Filename present
1569 else
1570 0 >r \ Filename not present
1571 then
1572 else
1573 0 >r \ Filename not present
1574 then
1575
1576 \ If there are other arguments, assume they are flags
1577 ?dup if
1578 concat-argv
1579 2dup s" temp_options" setenv
1580 drop free if free_error throw then
1581 else
1582 set-defaultoptions
1583 then
1584
1585 \ Bring back the filename, if one was provided
1586 r> if 2r> 1 else 0 then
1587;
1588
1589: get-arguments ( -- addrN lenN ... addr1 len1 N )
1590 0
1591 begin
1592 \ Get next word on the command line
1593 parse-word
1594 ?dup while
1595 queue-argv
1596 repeat
1597 drop ( empty string )
1598;
1599
1600: load-conf ( args -- flag )
1601 set-tempoptions
1602 argc >r
1603 s" temp_options" getenv dup -1 <> if
1604 queue-argv
1605 else
1606 drop
1607 then
1608 r> if ( a path was passed )
1609 load_kernel_and_modules
1610 else
1611 load_a_kernel
1612 ?dup 0= if ['] load_modules catch then
1613 then
1614;
1615
1616: read-password { size | buf len -- }
1617 size allocate if out_of_memory throw then
1618 to buf
1619 0 to len
1620 begin
1621 key
1622 dup backspace = if
1623 drop
--- 23 unchanged lines hidden ---
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 65883 2000-09-15 08:05:52Z dcs $
26
27\ Loader.rc support functions:
28\
29\ initialize_support ( -- ) initialize global variables
30\ initialize ( addr len -- ) as above, plus load_conf_files
31\ load_conf ( addr len -- ) load conf file given
32\ include_conf_files ( -- ) load all conf files in load_conf_files
33\ print_syntax_error ( -- ) print line and marker of where a syntax
--- 194 unchanged lines hidden (view full) ---
228 [char] ' parse
229 state @ if
230 postpone sliteral
231 then
232; immediate
233
234: 2>r postpone >r postpone >r ; immediate
235: 2r> postpone r> postpone r> ; immediate
236: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate
237
238\ Private definitions
239
240vocabulary support-functions
241only forth also support-functions definitions
242
243\ Some control characters constants
244
--- 1050 unchanged lines hidden (view full) ---
1295;
1296
1297\ Try to load a kernel; the kernel name is taken from one of
1298\ the following lists, as ordered:
1299\
1300\ 1. The "bootfile" environment variable
1301\ 2. The "kernel" environment variable
1302\
1303\ Flags are passed, if available.
1304\
1305\ The kernel gets loaded from the current module_path.
1306
1307: load_a_kernel ( flags len 1 | 0 -- flag )
1308 local args
1309 args 0= if 0 0 then
1310 2local flags
1311 0 0 2local kernel
1312 end-locals
1313
1314 \ Check if a default kernel name exists at all, exits if not
1315 s" bootfile" getenv dup -1 <> if
1316 to kernel
1317 flags kernel args 1+ try_multiple_kernels
1318 dup 0= if exit then
1319 then
1320 drop
1321
1322 s" kernel" getenv dup -1 <> if
1323 to kernel
1324 else
1325 drop
1326 1 exit \ Failure
1327 then
1328
1329 \ Try all default kernel names
1330 flags kernel args 1+ try_multiple_kernels
1331;
1332
1333\ Try to load a kernel; the kernel name is taken from one of
1334\ the following lists, as ordered:
1335\
1336\ 1. The "bootfile" environment variable
1337\ 2. The "kernel" environment variable
1338\
--- 35 unchanged lines hidden (view full) ---
1374
1375 0
1376 bootpath strcat
1377 path strcat
1378 2dup to newmodulepath
1379 modulepath setenv
1380
1381 \ Try all default kernel names
1382 args 2 = if flags 1 else 0 then
1383 load_a_kernel
1384 0= if ( success )
1385 oldmodulepath nip -1 <> if
1386 newmodulepath s" ;" strcat
1387 oldmodulepath strcat
1388 modulepath setenv
1389 newmodulepath drop free-memory
1390 oldmodulepath drop free-memory
1391 then
1392 0 exit
1393 then
1394
1395 \ Well, try without the prepended /boot/
1396 path newmodulepath drop swap move
1397 newmodulepath drop path nip
1398 2dup to newmodulepath
1399 modulepath setenv
1400
1401 \ Try all default kernel names
1402 args 2 = if flags 1 else 0 then
1403 load_a_kernel
1404 if ( failed once more )
1405 oldmodulepath restoreenv
1406 newmodulepath drop free-memory
1407 1
1408 else
1409 oldmodulepath nip -1 <> if
1410 newmodulepath s" ;" strcat
1411 oldmodulepath strcat
--- 39 unchanged lines hidden (view full) ---
1451 dup 0= if exit else drop then
1452
1453 \ Next, assume path points to the kernel
1454 flags path args try_multiple_kernels
1455;
1456
1457: load_kernel_and_modules ( flags len path len' 2 | path len' 1 -- flag )
1458 load_directory_or_file
1459 ?dup 0= if ['] load_modules catch then
1460;
1461
1462: initialize ( addr len -- )
1463 strdup conf_files .len ! conf_files .addr !
1464;
1465
1466: kernel_options ( -- addr len 1 | 0 )
1467 s" kernel_options" getenv
1468 dup -1 = if drop 0 else 1 then
1469;
1470
1471: kernel_and_options ( a u 1 | 0 -- a u a' u' 2 | a' u' 1 )
1472 kernel_options
1473 s" kernel" getenv
1474 rot 1+
1475;
1476
1477: load_kernel ( -- ) ( throws: abort )
1478 s" kernel" getenv
1479 dup -1 = if ( there isn't a "kernel" environment variable, try bootfile )
1480 drop
1481 kernel_options load_a_kernel
1482 else ( try finding a kernel using ${kernel} in various ways )
1483 kernel_options >r 2swap r> clip_args load_from_directory
1484 dup if
1485 drop
1486 kernel_and_options try_multiple_kernels
1487 then
1488 then
1489 abort" Unable to load a kernel!"
1490;
1491
1492: set-defaultoptions ( -- )
1493 s" kernel_options" getenv dup -1 = if
1494 drop
1495 else
1496 s" temp_options" setenv
1497 then
1498;
1499
1500: argv[] ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
1501 2dup = if 0 0 exit then
1502 dup >r
1503 1+ 2* ( skip N and ui )
1504 pick
1505 r>
1506 1+ 2* ( skip N and ai )
1507 pick
1508;
1509
1510: drop-args ( aN uN ... a1 u1 N -- )
1511 0 ?do 2drop loop
1512;
1513
1514: argc
1515 dup
1516;
1517
1518: queue-argv ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 )
1519 >r
1520 over 2* 1+ -roll
1521 r>
1522 over 2* 1+ -roll
1523 1+
1524;
1525
1526: unqueue-argv ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 )
1527 1- -rot
1528;
1529
1530: strlen(argv)
1531 dup 0= if 0 exit then
1532 0 >r \ Size
1533 0 >r \ Index
1534 begin
1535 argc r@ <>
1536 while
1537 r@ argv[]
1538 nip
1539 r> r> rot + 1+
1540 >r 1+ >r
1541 repeat
1542 r> drop
1543 r>
1544;
1545
1546: concat-argv ( aN uN ... a1 u1 N -- a u )
1547 strlen(argv) allocate if out_of_memory throw then
1548 0 2>r
1549
1550 begin
1551 argc
1552 while
1553 unqueue-argv
1554 2r> 2swap
1555 strcat
1556 s" " strcat
1557 2>r
1558 repeat
1559 drop-args
1560 2r>
1561;
1562
1563: set-tempoptions ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
1564 \ Save the first argument, if it exists and is not a flag
1565 argc if
1566 0 argv[] drop c@ [char] - <> if
1567 unqueue-argv 2>r \ Filename
1568 1 >r \ Filename present
1569 else
1570 0 >r \ Filename not present
1571 then
1572 else
1573 0 >r \ Filename not present
1574 then
1575
1576 \ If there are other arguments, assume they are flags
1577 ?dup if
1578 concat-argv
1579 2dup s" temp_options" setenv
1580 drop free if free_error throw then
1581 else
1582 set-defaultoptions
1583 then
1584
1585 \ Bring back the filename, if one was provided
1586 r> if 2r> 1 else 0 then
1587;
1588
1589: get-arguments ( -- addrN lenN ... addr1 len1 N )
1590 0
1591 begin
1592 \ Get next word on the command line
1593 parse-word
1594 ?dup while
1595 queue-argv
1596 repeat
1597 drop ( empty string )
1598;
1599
1600: load-conf ( args -- flag )
1601 set-tempoptions
1602 argc >r
1603 s" temp_options" getenv dup -1 <> if
1604 queue-argv
1605 else
1606 drop
1607 then
1608 r> if ( a path was passed )
1609 load_kernel_and_modules
1610 else
1611 load_a_kernel
1612 ?dup 0= if ['] load_modules catch then
1613 then
1614;
1615
1616: read-password { size | buf len -- }
1617 size allocate if out_of_memory throw then
1618 to buf
1619 0 to len
1620 begin
1621 key
1622 dup backspace = if
1623 drop
--- 23 unchanged lines hidden ---