obp/obp/fm/kernel/is.fth

\ ========== Copyright Header Begin ==========================================
\
\ Hypervisor Software File: is.fth
\
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\
\  - Do no alter or remove copyright notices
\
\  - Redistribution and use of this software in source and binary forms, with
\    or without modification, are permitted provided that the following
\    conditions are met:
\
\  - Redistribution of source code must retain the above copyright notice,
\    this list of conditions and the following disclaimer.
\
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\    Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\
\     This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility.
\
\ ========== Copyright Header End ============================================
id: @(#)is.fth 2.10 03/12/08 13:22:08
purpose:
copyright: Copyright 1994-2003 Sun Microsystems, Inc.  All Rights Reserved
copyright: Copyright 1985-1994 Bradley Forthware
copyright: Use is subject to license terms.

\ Prefix word for setting the value of variables, constants, user variables,
\ values, and deferred words.  State-smart so it is used the same way whether
[ifndef] in-dictionary-variables
\ interpreting or compiling.  You could now use IS in place of ! where speed
\ matters, because the newer faster IS is actually 20% faster than  !  (but
\ it's still not recommended practice.  Better to use VALUE.)
[else]
\ interpreting or compiling.  Don't use IS in place of ! where speed matters,
\ because IS is much slower than ! .
[then]
\
\ Examples:
\
\ 3 constant foo
\ 4 is foo
\
\ defer money
\ ' dollars is money
\ : european ['] euros is money ;

\ IS is a "generic store".
\ IS figures out where the data for a word is stored, and replaces that data.
\ The previous implementation was not particularly fast; this is much faster.

\ This is loaded before "order.fth"
\ only forth also hidden also definitions

\  In-dictionary variables are a leftover from the earliest FORTH
\  implementations.  They have no place in a ROMable target-system
\  and we are deprecating support for them; but Just In Case you
\  ever want to restore support for them, define the command-line
\  symbol:   in-dictionary-variables
[ifdef] in-dictionary-variables
   variable isvar
[then]

\  \  Replace this next one with something we actually use
\  0 value isval

headerless

[ifdef] run-time
: is-error  ( data acf -- )  true ( -32 ) abort" inappropriate use of `is'"  ;
[else]
: is-error  ( data acf -- )  ." Can't use is with " .name cr ( -32 ) abort  ;
[then]

headers

defer to-hook
' is-error is to-hook

headerless

: >bu  ( acf -- data-adr )  >body >user  ;

create word-types
]    limit              \ value
     #user              \ user variable
     key                \ defer
[ifdef] in-dictionary-variables
     isvar              \ in-dictionary variable
[then]
     bl                 \ constant
[  origin   token,-t    \ END   \ origin should be null

create data-locs
]    >bu                \ value
     >bu                \ user variable
     >bu                \ defer
[ifdef] in-dictionary-variables
     >body              \ in-dictionary variable
[then]
     >body              \ constant
[

\  One of these words will be called when interpreting  IS ,
\  based on the word-type of the target-word.
\  When compiling  IS , the group below will be used.
: is-user  ( n acf -- )  >bu       !  ;
: is-defer ( n acf -- )  >bu  token!  ;
: is-const ( n acf -- )  >body     !  ;

create !data-ops
]    is-user            \ value
     is-user            \ user variable
     is-defer           \ defer
[ifdef] in-dictionary-variables
     is-const           \ in-dictionary variable
[then]
     is-const           \ constant
[

\  These are the words that are compiled-in when compiling  IS
[ifnexist] (is-user)
   : (is-user)  ( n -- )  ip> dup ta1+ >ip  token@  is-user  ;
[then]
[ifnexist] (is-defer)
   : (is-defer) ( n -- )  ip> dup ta1+ >ip  token@  is-defer ;
[then]


\  We may obsolete this eventually.  Constants should stay constant...
: (is-const) ( n -- )  ip> dup ta1+ >ip  token@  is-const ;

create (!data-ops)
]    (is-user)          \ value
     (is-user)          \ user variable
     (is-defer)         \ defer
[ifdef] in-dictionary-variables
     (is-const)         \ in-dictionary variable
[then]
     (is-const)         \ constant
[

: associate  ( acf -- true  |  index false )
   word-type  ( n )
   word-types  begin              ( n adr )
      2dup get-token?             ( n adr n  false | acf true )
   while                          ( n adr n acf )
      word-type  = if             ( n adr )
         word-types -             ( n index )
         \t32 2/ 2/               ( n index ) \ equiv. of '/token /'
         \t16 2/                  ( n index )
         nip false  exit          ( index false )
      then                        ( n adr )
      ta1+                        ( n adr' )
   repeat                         ( n adr n )
   3drop true                     ( true )
;

: +token@  ( index table -- acf )  swap ta+ token@  ;
: +execute ( index table -- )      +token@ execute  ;

: kerntype?  ( acf -- flag )
   associate  if  false  else  drop true  then  ( flag )
;

headers
: behavior  ( defer-acf -- acf2 )  >bu token@  ;

: (is  ( data acf -- )
   dup  associate  if  is-error  then   ( data acf index )
   !data-ops +execute                   ( )
;

: >data  ( acf -- data-adr )
   dup associate  if        ( acf )
      >body                 ( data-adr )
   else                     ( acf index )
      data-locs +execute    ( data-adr )
   then                     ( data-adr )
;

[ifndef] run-time
: compile-is ( acf -- )
   dup associate drop   \  Already filtered through  kerntype   ( acf index )
   (!data-ops) +token@                                          ( acf is-acf )
   token, token,
;
: do-is  ( data acf -- )
   dup kerntype?  if     ( [data] acf )
      state @  if   compile-is  else  (is   then
   else                    ( [data] acf )
      to-hook
   then
;

\ is is the word that is actually used by applications
: is  \ name  ( data -- )
   ' do-is
; immediate

\ only forth also definitions

[then]