r504 - forth/kernel forth/lib ofw/core

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