[OpenBIOS] r504 - forth/kernel forth/lib ofw/core
svn at openbios.org
svn at openbios.org
Mon Jul 30 20:19:56 CEST 2007
Author: wmb
Date: 2007-07-30 20:19:56 +0200 (Mon, 30 Jul 2007)
New Revision: 504
Modified:
forth/kernel/kernel.fth
forth/kernel/sysio.fth
forth/lib/loadcomm.fth
forth/lib/stringop.fth
ofw/core/ofwcore.fth
Log:
Added string macro expansion to the base build.
Modified: forth/kernel/kernel.fth
===================================================================
--- forth/kernel/kernel.fth 2007-07-28 17:45:18 UTC (rev 503)
+++ forth/kernel/kernel.fth 2007-07-30 18:19:56 UTC (rev 504)
@@ -38,6 +38,7 @@
defer resize ( adr #bytes -- adr' ior )
defer sync-cache ( adr len -- ) ' 2drop is sync-cache
+defer $getenv ( adr len -- false | adr' len' true )
defer #out ( -- adr )
defer #line ( -- adr )
@@ -50,6 +51,8 @@
: default-type ( adr len -- )
0 max bounds ?do pause i c@ (emit loop
;
+: null-$getenv ( adr len -- true ) 2drop true ;
+
\ headerless \ from campus version
nuser (#out \ number of characters emitted
\ headers \ from campus version
@@ -61,6 +64,7 @@
' key1 is key
' (#out is #out
' (#line is #line
+' null-$getenv is $getenv
decimal
Modified: forth/kernel/sysio.fth
===================================================================
--- forth/kernel/sysio.fth 2007-07-28 17:45:18 UTC (rev 503)
+++ forth/kernel/sysio.fth 2007-07-30 18:19:56 UTC (rev 504)
@@ -161,6 +161,10 @@
: sys-sync-cache ( adr len -- ) swap 116 syscall 2drop ;
+: sys-$getenv ( adr len -- true | adr' len' false )
+ $cstr d# 84 syscall drop retval dup if cscount false else drop true then
+;
+
: install-wrapper-alloc ( -- )
\ Don't use "is" in case a relocation map needs to be allocated first
['] sys-alloc-mem ['] alloc-mem >body >user token!
@@ -185,6 +189,7 @@
install-wrapper-alloc
\ init-relocation goes here, for versions that need it
install-wrapper-key
+ ['] sys-$getenv is $getenv
;
headers
Modified: forth/lib/loadcomm.fth
===================================================================
--- forth/lib/loadcomm.fth 2007-07-28 17:45:18 UTC (rev 503)
+++ forth/lib/loadcomm.fth 2007-07-30 18:19:56 UTC (rev 504)
@@ -25,6 +25,7 @@
fload ${BP}/forth/kernel/endian.fth
fload ${BP}/forth/lib/strings.fth
+fload ${BP}/forth/lib/stringop.fth
fload ${BP}/forth/lib/fastspac.fth
Modified: forth/lib/stringop.fth
===================================================================
--- forth/lib/stringop.fth 2007-07-28 17:45:18 UTC (rev 503)
+++ forth/lib/stringop.fth 2007-07-30 18:19:56 UTC (rev 504)
@@ -1,10 +1,6 @@
\ See license at end of file
purpose: String tools to manipulate OS file pathnames
-: $getenv ( adr len -- false | adr' len' true )
- $cstr d# 84 syscall drop retval dup if cscount true then
-;
-
\ head$ is the portion of str3 preceding str2, and tail$ is the portion
\ of str3 following str2
: break$ ( str2 str3 -- head$ tail$ )
@@ -38,13 +34,25 @@
;
vocabulary macros
-: macro: ( "name" "value" -- )
- also macros definitions create previous definitions 0 parse ",
+: $set-macro ( value$ name$ -- )
+ warning @ warning off
+ also macros definitions $header create-cf previous definitions ( value$ )
+ warning !
+ ",
does> ( -- adr len ) count
;
+: $get-macro ( name$ -- true | value$ false )
+ ['] macros search-wordlist if execute false else true then
+;
+
+: macro: ( "name" "value" -- ) safe-parse-word 0 parse 2swap $set-macro ;
+
: expansion ( macro-name$ -- macro-value$ )
- 2dup ['] macros search-wordlist if nip nip execute exit then ( name$ )
- $getenv 0= if " " then
+ 2dup $get-macro if ( name$ )
+ $getenv if " " then ( value$ )
+ else ( name$ value$ )
+ 2nip ( value$ )
+ then ( value$ )
;
\ Expand references to environment variables within str1
@@ -82,24 +90,25 @@
: remaining ( -- adr len ) source >in @ /string ;
\ The complexity with last-delim is necessary in order to handle the
\ case where files" is at the very end of a line.
-0 value last-delim
+variable last-delim
: files" ( "strings" -- adr len )
- 0 to last-delim
+ last-delim off
here
begin
#remaining if
[char] " parse ( adr len ) $,
- source drop >in @ + 1- c@ to last-delim
+ source drop >in @ + 1- c@ last-delim !
then
#remaining 0=
while
- >in @ if last-delim [char] " <> else true then
+ >in @ if last-delim @ [char] " <> else true then
while
bl c,
refill 0=
until then then ( adr )
here over -
;
+
\ LICENSE_BEGIN
\ Copyright (c) 2006 FirmWorks
\
Modified: ofw/core/ofwcore.fth
===================================================================
--- ofw/core/ofwcore.fth 2007-07-28 17:45:18 UTC (rev 503)
+++ ofw/core/ofwcore.fth 2007-07-30 18:19:56 UTC (rev 504)
@@ -501,7 +501,7 @@
config-ro
;
-: $getenv ( name$ -- true | value$ false )
+: ofw-$getenv ( name$ -- true | value$ false )
2dup $find-option if ( name$ xt )
nip nip ( xt )
>r r@ get r> decode -null false ( prop$ false )
@@ -3717,6 +3717,7 @@
['] heap-alloc-mem is alloc-mem
['] heap-free-mem is free-mem
['] resize-memory is resize
+ ['] ofw-$getenv is $getenv
;
headers
More information about the OpenBIOS
mailing list