[PATCH] Adds the get-time word to the dictionary. Used to obtain the current time.

[Programmingkid]

The get-time word is a word that is used to obtain the current time. It is used on Apple's Open Firmware.

signed-off-by: John Arbuckle

---
 forth/system/main.fs |   21 +++++++++++++++++++++
 1 files changed, 21 insertions(+), 0 deletions(-)

diff --git a/forth/system/main.fs b/forth/system/main.fs
index 122ab1f..6867cf3 100644
--- a/forth/system/main.fs
+++ b/forth/system/main.fs
@@ -58,3 +58,24 @@ variable DIAG-list

outer-interpreter
 ;
+
+\ Returns the time  ( -- second minute hour day month year )
+: get-time
+   " get-time"           ( addr len )
+   " rtc" open-dev   ( addr len device )
+   dup	                   ( addr len device device )
+   
+   0=  if   \ if the real-time clock isn't available
+      cr
+      3drop               ( ) 
+      true                   ( flag )
+      abort" Sorry but get-time isn't available for your system. "
+   then
+   
+   dup                      ( addr len device device )
+   >R                        ( addr len device )          ( R: device ) 
+   $call-method      ( addr len device -- )      ( R: device )
+   R>                        ( device )                          ( R: )
+   close-dev            ( device -- )
+;
+

[PATCH] Adds the get-time word to the dictionary. Used to obtain the current time.

[Tarl Neustaedter]

On 2012-Sep-23 13:26 , Programmingkid wrote:
> +\ Returns the time  ( -- second minute hour day month year )
> +: get-time
> " get-time"           ( addr len )
> " rtc" open-dev   ( addr len device )
> dup	                   ( addr len device device )
> 0=  if   \ if the real-time clock isn't available
>  cr
>  3drop               ( )
>  true                   ( flag )
>  abort" Sorry but get-time isn't available for your system. "
> then
> dup                      ( addr len device device )
> > R                        ( addr len device )          ( R: device )
> $call-method      ( addr len device -- )      ( R: device )
> R>                        ( device )                          ( R: )
> close-dev            ( device -- )
>
> +;

Coding comments...

* Rather than using "addr len" on the stack to represent the pointer
    to " get-time", for short strings, we might actually put the string
    itself in the comments. E.g., rather than ( addr len device ), you
    might see ( "get-time" device ). Alternatively, $xxxx by convention
    represents the two-cell pointer to a text string, so you might see (
    $get-time device ) as the stack comment.
  * But even better, rather than putting " get-time" on the stack at the
    top of the routine and having to carry it all the way down and play
    games with the stack, don't put it on the stack until you use it.
    Something like:

: get-time
    " rtc" open-dev                   ( ihandle )
    ?dup 0= if
       cr abort" Sorry but no rtc node is present on this system"
    then                              ( ihandle )
    >r " get-time" r@ $call-method    ( <returned args - 6 of em? Yikes > )
    r> close-dev                      ( <returned args> )
;

[PATCH] Adds the get-time word to the dictionary. Used to obtain the current time.

[Segher Boessenkool]

> : get-time
>    " rtc" open-dev                   ( ihandle )
>    ?dup 0= if
>       cr abort" Sorry but no rtc node is present on this system"
>    then                              ( ihandle )
> > r " get-time" r@ $call-method    ( <returned args - 6 of em?
>
> Yikes > )
>    r> close-dev                      ( <returned args> )
> ;

: get-time
   s" rtc" s" get-time" execute-device-method
   0= ABORT" Sorry but no rtc node is present on this system" ;

(note that ABORT" takes a flag as input), but better is

: get-time
   s" rtc" s" get-time" execute-device-method
   0= IF fake-some-sort-of-plausible-time-1970-or-so THEN ;

which is pretty much what Apple's OF does.  execute-device-method
is not the same thing as open-dev followed by $call-method: it
does not call "open" in the instance for the device itself (you
only need that for devices that can have multiple clients at the
same time and need to keep state for each client; or when instead
you need to prevent concurrent access from multiple clients, by
having the second open fail).

Segher