forth/device/other.fs

   1 \ tag: Other FCode functions
   2 \
   3 \ this code implements IEEE 1275-1994 ch. 5.3.7
   4 \
   5 \ Copyright (C) 2003 Stefan Reinauer
   6 \
   7 \ See the file "COPYING" for further information about
   8 \ the copyright and warranty status of this work.
   9 \
  10
  11 \ The current diagnostic setting
  12 defer _diag-switch?
  13
  14
  15 \
  16 \ 5.3.7 Other FCode functions
  17 \
  18
  19 hex
  20
  21 \ 5.3.7.1 Peek/poke
  22
  23 : cpeek    ( addr -- false | byte true )
  24   c@ true
  25   ;
  26
  27 : wpeek    ( waddr -- false | w true )
  28   w@ true
  29   ;
  30
  31 : lpeek    ( qaddr -- false | quad true )
  32   l@ true
  33   ;
  34
  35 : cpoke    ( byte addr -- okay? )
  36   c! true
  37   ;
  38
  39 : wpoke    ( w waddr -- okay? )
  40   w! true
  41   ;
  42
  43 : lpoke    ( quad qaddr -- okay? )
  44   l! true
  45   ;
  46
  47
  48 \ 5.3.7.2 Device-register access
  49
  50 : rb@    ( addr -- byte )
  51   ;
  52
  53 : rw@    ( waddr -- w )
  54   ;
  55
  56 : rl@    ( qaddr -- quad )
  57   ;
  58
  59 : rb!    ( byte addr -- )
  60   ;
  61
  62 : rw!    ( w waddr -- )
  63   ;
  64
  65 : rl!    ( quad qaddr -- )
  66   ;
  67
  68 : rx@ ( oaddr - o )
  69   state @ if
  70     h# 22e get-token if , else execute then
  71   else
  72     h# 22e get-token drop execute
  73   then
  74   ; immediate
  75
  76 : rx! ( o oaddr -- )
  77   state @ if
  78     h# 22f get-token if , else execute then
  79   else
  80     h# 22f get-token drop execute
  81   then
  82   ; immediate
  83
  84 \ 5.3.7.3 Time
  85
  86 0 value dummy-msecs
  87
  88 : get-msecs    ( -- n )
  89   dummy-msecs dup 1+ to dummy-msecs
  90   ;
  91
  92 : ms    ( n -- )
  93   get-msecs +
  94   begin dup get-msecs < until
  95   drop
  96   ;
  97
  98 : alarm    ( xt n -- )
  99   2drop
 100   ;
 101
 102 : user-abort    ( ... -- )  ( R: ... -- )
 103   ;
 104
 105
 106 \ 5.3.7.4 System information
 107 0003.0000 value fcode-revision    ( -- n )
 108
 109 : mac-address    ( -- mac-str mac-len )
 110   ;
 111
 112
 113 \ 5.3.7.5 FCode self-test
 114 : display-status    ( n -- )
 115   ;
 116
 117 : memory-test-suite ( addr len -- fail? )
 118   ;
 119
 120 : mask    ( -- a-addr )
 121   ;
 122
 123 : diagnostic-mode?     ( -- diag? )
 124   \ Return the NVRAM diag-switch? setting
 125   _diag-switch?
 126   ;
 127
 128 \ 5.3.7.6 Start and end.
 129
 130 \ Begin program with spread 0 followed by FCode-header.
 131 : start0 ( -- )
 132   0 fcode-spread !
 133   offset16
 134   fcode-header
 135   ;
 136
 137 \ Begin program with spread 1 followed by FCode-header.
 138 : start1 ( -- )
 139   1 to fcode-spread
 140   offset16
 141   fcode-header
 142   ;
 143
 144 \ Begin program with spread 2 followed by FCode-header.
 145 : start2 ( -- )
 146   2 to fcode-spread
 147   offset16
 148   fcode-header
 149   ;
 150
 151 \ Begin program with spread 4 followed by FCode-header.
 152 : start4 ( -- )
 153   4 to fcode-spread
 154   offset16
 155   fcode-header
 156   ;
 157
 158 \ Begin program with spread 1 followed by FCode-header.
 159 : version1 ( -- )
 160   1 to fcode-spread
 161   fcode-header
 162   ;
 163
 164 \ Cease evaluating this FCode program.
 165 : end0 ( -- )
 166   true fcode-end !
 167   ;
 168
 169 \ Cease evaluating this FCode program.
 170 : end1 ( -- )
 171   end0
 172   ;
 173
 174 \ Standard FCode number for undefined FCode functions.
 175 : ferror ( -- )
 176   ." undefined fcode# encountered." cr
 177   true fcode-end !
 178   ;
 179
 180 \ Pause FCode evaluation if desired; can resume later.
 181 : suspend-fcode ( -- )
 182   \ NOT YET IMPLEMENTED.
 183   ;
 184
 185
 186 \ Evaluate FCode beginning at location addr.
 187
 188 \ : byte-load ( addr xt -- )
 189 \   \ this word is implemented in feval.fs
 190 \   ;
 191
 192 \ Set address and arguments of new device node.
 193 : set-args ( arg-str arg-len unit-str unit-len -- )
 194   ?my-self drop
 195
 196   depth 1- >r
 197   " decode-unit" ['] $call-parent catch if
 198     2drop 2drop
 199   then
 200
 201   my-self ihandle>phandle >dn.probe-addr \ offset
 202   begin depth r@ > while
 203     dup na1+ >r ! r>
 204   repeat
 205   r> 2drop
 206
 207   my-self >in.arguments 2@ free-mem
 208   strdup my-self >in.arguments 2!
 209 ;
 210
 211 : dma-alloc
 212   s" dma-alloc" $call-parent
 213   ;