qemu/roms/SLOF/slof/fs/fcode/core.fs

   1 \ *****************************************************************************
   2 \ * Copyright (c) 2004, 2008 IBM Corporation
   3 \ * All rights reserved.
   4 \ * This program and the accompanying materials
   5 \ * are made available under the terms of the BSD License
   6 \ * which accompanies this distribution, and is available at
   7 \ * http://www.opensource.org/licenses/bsd-license.php
   8 \ *
   9 \ * Contributors:
  10 \ *     IBM Corporation - initial implementation
  11 \ ****************************************************************************/
  12
  13 : ?offset16 ( -- true|false )
  14   fcode-offset 2 =
  15   ;
  16
  17 : ?arch64 ( -- true|false )
  18   cell 8 =
  19   ;
  20
  21 : ?bigendian ( -- true|false )
  22   deadbeef fcode-num !
  23   fcode-num ?arch64 IF 4 + THEN
  24   c@ de =
  25   ;
  26
  27 : reset-fcode-end ( -- )
  28   false fcode-end !
  29   ;
  30
  31 : get-ip ( -- n )
  32   ip @
  33   ;
  34
  35 : set-ip ( n -- )
  36   ip !
  37   ;
  38
  39 : next-ip ( -- )
  40   get-ip 1+ set-ip
  41   ;
  42
  43 : jump-n-ip ( n -- )
  44   get-ip + set-ip
  45   ;
  46
  47 : read-byte ( -- n )
  48   get-ip fcode-rb@
  49   ;
  50
  51 : ?compile-mode ( -- on|off )
  52   state @
  53   ;
  54
  55 : save-evaluator-state
  56   get-ip               eva-debug? IF ." saved ip "           dup . cr THEN
  57   fcode-end @          eva-debug? IF ." saved fcode-end "    dup . cr THEN
  58   fcode-offset         eva-debug? IF ." saved fcode-offset " dup . cr THEN
  59 \ local fcodes are currently NOT saved!
  60   fcode-spread         eva-debug? IF ." saved fcode-spread " dup . cr THEN
  61   ['] fcode@ behavior  eva-debug? IF ." saved fcode@ "       dup . cr THEN
  62   ;
  63
  64 : restore-evaluator-state
  65   eva-debug? IF ." restored fcode@ "       dup . cr THEN  to fcode@
  66   eva-debug? IF ." restored fcode-spread " dup . cr THEN  to fcode-spread
  67 \ local fcodes are currently NOT restored!
  68   eva-debug? IF ." restored fcode-offset " dup . cr THEN  to fcode-offset
  69   eva-debug? IF ." restored fcode-end "    dup . cr THEN  fcode-end !
  70   eva-debug? IF ." restored ip "           dup . cr THEN  set-ip
  71   ;
  72
  73 : token-table-index ( fcode# -- addr )
  74   cells token-table +
  75   ;
  76
  77 : join-immediate ( xt immediate? addr -- xt+immediate? addr )
  78   -rot + swap
  79   ;
  80
  81 : split-immediate ( xt+immediate? -- xt immediate? )
  82   dup 1 and 2dup - rot drop swap
  83   ;
  84
  85 : literal, ( n -- )
  86   postpone literal
  87   ;
  88
  89 : fc-string,
  90   postpone sliteral
  91   dup c, bounds ?do i c@ c, loop
  92   ;
  93
  94 : set-token ( xt immediate? fcode# -- )
  95   token-table-index join-immediate !
  96   ;
  97
  98 : get-token ( fcode# -- xt immediate? )
  99   token-table-index @ split-immediate
 100   ;
 101
 102 ( ---------------------------------------------------- )
 103
 104 #include "little-big.fs"
 105
 106 ( ---------------------------------------------------- )
 107
 108 : read-fcode# ( -- FCode# )
 109   read-byte
 110   dup 01 0F between IF drop read-fcode-num16 THEN
 111   ;
 112
 113 : read-header ( adr -- )
 114   next-ip read-byte        drop
 115   next-ip read-fcode-num16 drop
 116   next-ip read-fcode-num32 drop
 117   ;
 118
 119 : read-fcode-string ( -- str len )
 120   read-byte            \ get string length ( -- len )
 121   next-ip get-ip       \ get string addr   ( -- len str )
 122   swap                 \ type needs the parameters swapped ( -- str len )
 123   dup 1- jump-n-ip     \ jump to the end of the string in FCode
 124   ;
 125
 126
 127 -1 VALUE break-fcode-addr
 128 0 VALUE break-fcode-steps
 129
 130 : evaluate-fcode ( -- )
 131    BEGIN
 132       get-ip break-fcode-addr = IF
 133          TRUE fcode-end !
 134       THEN
 135       fcode-end @ 0=
 136    WHILE
 137       fcode@                               ( fcode# )
 138       eva-debug? IF
 139          dup
 140          get-ip 8 u.r ." : "
 141          ." [" 3 u.r ." ] "
 142       THEN
 143       \ When it is not immediate and in compile-mode, then compile
 144       get-token 0= ?compile-mode AND IF    ( xt )
 145          compile,
 146       ELSE                                 \ immediate or "interpretation" mode
 147          eva-debug? IF dup xt>name type space THEN
 148          execute
 149       THEN
 150       eva-debug? IF .s cr THEN
 151       break-fcode-steps IF
 152          break-fcode-steps 1- TO break-fcode-steps
 153          break-fcode-steps 0= IF
 154             TRUE fcode-end !
 155          THEN
 156       THEN
 157       next-ip
 158    REPEAT
 159 ;
 160
 161 \ Run FCODE for n steps
 162 : steps-fcode  ( n -- )
 163    to break-fcode-steps
 164    break-fcode-addr >r -1 to break-fcode-addr
 165    reset-fcode-end
 166    evaluate-fcode
 167    r> to break-fcode-addr
 168 ;
 169
 170 \ Step through one FCODE instruction
 171 : step-fcode  ( -- )
 172    1 steps-fcode
 173 ;