obp/obp/fm/kernel/interp.fth

\ ========== Copyright Header Begin ==========================================
\
\ Hypervisor Software File: interp.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: @(#)interp.fth 2.19 03/12/08 13:22:06
purpose:
copyright: Copyright 1990-2003 Sun Microsystems, Inc.  All Rights Reserved
copyright: Copyright 1985-1990 Bradley Forthware
copyright: Use is subject to license terms.

\ The Text Interpreter

\ Input stream parsing

\ Error reporting
defer mark-error  ' noop is mark-error
defer show-error  ' noop is show-error
: where  ( -- )  mark-error show-error  ;

: lose  ( -- )  true ( -13) abort" Undefined word encountered "  ;

\ Number parsing
hex
: >number  ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
  \ convert double number, leaving address of first unconverted byte
   begin  dup  while                  ( ud adr len )
      over c@  base @  digit          ( ud adr len  digit true  |  char false )
      0=  if  drop exit  then         ( ud adr len  digit )
      >r  2swap  r>                   ( adr len ud  digit )
      swap base @ um*  drop           ( adr len ud.low  digit ud.high' )
      rot base @ um*  d+              ( adr len  ud' )
      2swap  1 /string                ( ud' adr len )
   repeat                             ( ud' adr len )
;
: numdelim?  ( char -- flag )  dup ascii . =  swap ascii , =  or  ;
: $dnumber?  ( adr len -- [ n .. ] #cells )
   dup  0=  if  ( adr 0 )  nip  exit  then
   0 0  2swap                                         ( ud $ )
   over c@ ascii - =                                  ( ud $ neg? )
   dup  >r  negate /string                            ( ud $' )  ( r: neg? )

   \ Convert groups of digits possibly separated by periods or commas
   begin  >number  dup 1 >  while                     ( ud' $' )
      over c@ numdelim?  0=  if                       ( ud' $' )
         2drop  r> 3drop  0  exit                     ( ud' $' )
      then                                            ( ud' $' )
      1 /string                                       ( ud' $' )
   repeat                                             ( ud' $' )

   if                                                 ( ud adr )
      \ Do not accept a trailing comma, thus preventing,
      \ for example, "c," from being interpreted as a number
      c@  ascii . =  if                               ( ud )
         true                                         ( ud dbl? )
      else                                            ( ud )
         r> 3drop  0  exit
      then                                            ( ud dbl? )
   else                                               ( ud adr )
      drop false                                      ( ud dbl? )
   then                                               ( ud dbl? )

   over or  if                                        ( ud )
      r>  if  dnegate  then  2
   else
      drop  r>  if  negate  then  1
   then
;

defer do-defined    ( cfa -1 | cfa 1  -- ?? )
defer $do-undefined  ( adr len -- )

headers
defer do-literal
: (do-literal)  ( n 1 | d 2 -- n | d | )
   state @  if
      2 =  if  [compile] dliteral  else  [compile] literal  then
   else
      drop
   then
;
' (do-literal) is do-literal
defer $handle-literal?  ( adr len -- handled? )
: ($handle-literal?)  ( adr len -- handled? )
   $dnumber?  dup  if  do-literal true  then
;
' ($handle-literal?) is $handle-literal?

headers
: $compile  ( adr len -- ?? )
   2dup  2>r                        ( adr len )  ( r: adr len )
   $find  dup  if                   ( xt +-1 )
      2r> 2drop do-defined          ( )
   else                             ( adr' len' 0 )
      3drop                         ( )
      2r@ $handle-literal?  0=  if  ( )
         2r@  $do-undefined         ( )
      then
      2r> 2drop
  then
;
headerless
: interpret-do-defined  ( cfa -1 | cfa 1 -- ?? )  drop execute  ;
: compile-do-defined    ( cfa -1 | cfa 1 -- )
  0> if    execute   \ if immediate
     else  compile,  \ if not immediate
     then
;
headers
: .not-found  ( adr len -- )  (compile-time-error) where type ."  ?" cr  ;
headerless
\ Abort after an undefined word in interpret state
: $interpret-do-undefined  ( adr len -- )
   (compile-time-error)  mark-error set-abort-message  d# -13 throw
;
\ Compile a surrogate for an undefined word in compile state
: $compile-do-undefined    ( adr len -- )  .not-found  compile lose  ;

headers
defer [ immediate
headerless
: ([)  ( -- )
  ['] interpret-do-defined    is do-defined
  ['] $interpret-do-undefined is $do-undefined
  state off
;
' ([) is [

headers
defer ]
headerless
: (])  ( -- )
  ['] compile-do-defined     is do-defined
  ['] $compile-do-undefined  is $do-undefined
  state on
;
' (]) is ]

headers
\ Run-time error checking
: ?stack  ( ?? -- )
   sp@  sp0 @  swap       u<  ( -4 ) abort" Stack Underflow"
   sp@  sp0 @  ps-size -  u<  ( -3 ) abort" Stack Overflow"
;

defer ?permitted  ' noop is ?permitted

defer interpret
: (interpret  ( -- )
   begin
\     ?stack
      parse-word dup
   while
      ?permitted
      $compile
   repeat
   2drop
;
' (interpret  is interpret

\ Ensure that the cursor in on an empty line.
: ??cr  ( -- )  #out @  if  cr  then  ;

\ This hack is for users of window systems.  If you pick up with the
\ mouse an entire previous command line, including the prompt, then
\ paste it into the current line, Forth will ignore the prompt.
: ok  ( -- )  ;

defer status  ( -- )  ' noop is status


\ A hook for automatic pagination

defer mark-output  ( -- )  ' noop is mark-output


\ Prompts the user for another line of input.  Executed only if the input
\ stream is coming from a terminal.

defer (ok) ( -- )
: "ok" ." ok " ;
' "ok" is (ok)

defer reset-page
' noop is reset-page
: do-prompt  ( -- )  reset-page prompt  ;