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

   1 \ *****************************************************************************
   2 \ * Copyright (c) 2011 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 \ * Support for old-fashioned local values in FCODE.
  14 \ *
  15 \ * There is one old FCODE tokenizer that uses the FCODE opcodes in the range
  16 \ * of 0x407 to 0x41f for supporting Forth local values. Each locals stack
  17 \ * frame contains 8 variables. The opcodes from 0x407 to 0x40f are used to
  18 \ * push 0 up to 8 values from the normal data stack into the current locals
  19 \ * stack frame. All other variables in the current stack frame are not
  20 \ * pre-initialized.
  21 \ * The opcodes from 0x410 to 0x417 can be used for reading the first, second,
  22 \ * ... eighth value out of the locals stack frame, and the opcode from 0x418
  23 \ * to 0x41f can be used to set the first, second, ... eighth value in the
  24 \ * stack frame respectively.
  25 \ *
  26
  27 80 cells CONSTANT LOCALS-STACK-SIZE
  28
  29 LOCALS-STACK-SIZE BUFFER: localsstackbuf
  30
  31 localsstackbuf VALUE localsstack
  32
  33
  34 : fc-local@  ( n -- val )
  35    cells localsstack swap - @
  36 ;
  37
  38 : fc-local-1-@  1 fc-local@ ;
  39 : fc-local-2-@  2 fc-local@ ;
  40 : fc-local-3-@  3 fc-local@ ;
  41 : fc-local-4-@  4 fc-local@ ;
  42 : fc-local-5-@  5 fc-local@ ;
  43 : fc-local-6-@  6 fc-local@ ;
  44 : fc-local-7-@  7 fc-local@ ;
  45 : fc-local-8-@  8 fc-local@ ;
  46
  47
  48 : fc-local!  ( val n -- )
  49    cells localsstack swap - !
  50 ;
  51
  52 : fc-local-1-!  1 fc-local! ;
  53 : fc-local-2-!  2 fc-local! ;
  54 : fc-local-3-!  3 fc-local! ;
  55 : fc-local-4-!  4 fc-local! ;
  56 : fc-local-5-!  5 fc-local! ;
  57 : fc-local-6-!  6 fc-local! ;
  58 : fc-local-7-!  7 fc-local! ;
  59 : fc-local-8-!  8 fc-local! ;
  60
  61
  62 0 VALUE uses-locals?
  63
  64 \ Create space for the current function on the locals stack.
  65 \ Pre-initialized the n first locals with the n top-most data stack items.
  66 \ Note: Each function can use up to 8 (initialized or uninitialized) locals.
  67 : (fc-push-locals)  ( ... n -- )
  68    \ cr ." pushing " dup . ." locals" cr
  69    8 cells localsstack + TO localsstack
  70    localsstack localsstackbuf -
  71    LOCALS-STACK-SIZE > ABORT" Locals stack exceeded!"
  72    ?dup IF
  73       ( ... n ) 1 swap DO
  74          i fc-local!              \ Store pre-initialized locals
  75       -1 +LOOP
  76    THEN
  77 ;
  78
  79 : fc-push-locals  ( n -- )
  80    \ cr ." compiling push for " dup . ." locals" cr
  81    uses-locals? ABORT" Definition pushes locals multiple times!"
  82    true TO uses-locals?
  83    ( n ) ['] literal execute
  84    ['] (fc-push-locals) compile,
  85 ;
  86
  87 : fc-push-0-locals  0 fc-push-locals ;
  88 : fc-push-1-locals  1 fc-push-locals ;
  89 : fc-push-2-locals  2 fc-push-locals ;
  90 : fc-push-3-locals  3 fc-push-locals ;
  91 : fc-push-4-locals  4 fc-push-locals ;
  92 : fc-push-5-locals  5 fc-push-locals ;
  93 : fc-push-6-locals  6 fc-push-locals ;
  94 : fc-push-7-locals  7 fc-push-locals ;
  95 : fc-push-8-locals  8 fc-push-locals ;
  96
  97
  98 : fc-pop-locals  ( -- )
  99    \ ." popping locals" cr
 100    localsstack 8 cells - TO localsstack
 101    localsstack localsstackbuf - 0 < ABORT" Locals stack undeflow!"
 102 ;
 103
 104
 105 : fc-locals-exit
 106    uses-locals? IF
 107       \ ." compiling pop-locals for exit" cr
 108       ['] fc-pop-locals compile,
 109    THEN
 110    ['] exit compile,
 111 ;
 112
 113 : fc-locals-b(;)
 114    uses-locals? IF
 115       \ ." compiling pop-locals for b(;)" cr
 116       ['] fc-pop-locals compile,
 117    THEN
 118    false TO uses-locals?
 119    ['] b(;) execute
 120 ;
 121
 122
 123 : fc-set-locals-tokens  ( -- )
 124    ['] fc-push-0-locals 1 407 set-token
 125    ['] fc-push-1-locals 1 408 set-token
 126    ['] fc-push-2-locals 1 409 set-token
 127    ['] fc-push-3-locals 1 40a set-token
 128    ['] fc-push-4-locals 1 40b set-token
 129    ['] fc-push-5-locals 1 40c set-token
 130    ['] fc-push-6-locals 1 40d set-token
 131    ['] fc-push-7-locals 1 40e set-token
 132    ['] fc-push-8-locals 1 40f set-token
 133
 134    ['] fc-local-1-@ 0 410 set-token
 135    ['] fc-local-2-@ 0 411 set-token
 136    ['] fc-local-3-@ 0 412 set-token
 137    ['] fc-local-4-@ 0 413 set-token
 138    ['] fc-local-5-@ 0 414 set-token
 139    ['] fc-local-6-@ 0 415 set-token
 140    ['] fc-local-7-@ 0 416 set-token
 141    ['] fc-local-8-@ 0 417 set-token
 142
 143    ['] fc-local-1-! 0 418 set-token
 144    ['] fc-local-2-! 0 419 set-token
 145    ['] fc-local-3-! 0 41a set-token
 146    ['] fc-local-4-! 0 41b set-token
 147    ['] fc-local-5-! 0 41c set-token
 148    ['] fc-local-6-! 0 41d set-token
 149    ['] fc-local-7-! 0 41e set-token
 150    ['] fc-local-8-! 0 41f set-token
 151
 152    ['] fc-locals-exit 1 33 set-token
 153    ['] fc-locals-b(;) 1 c2 set-token
 154 ;
 155 fc-set-locals-tokens