Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ kernel.fs GForth kernel 17dec92py |
| 2 : | |||
| 3 : | anton | 1.61 | \ Copyright (C) 1995,1998,2000,2003,2004,2005,2006,2007 Free Software Foundation, Inc. |
| 4 : | anton | 1.1 | |
| 5 : | \ This file is part of Gforth. | ||
| 6 : | |||
| 7 : | \ Gforth is free software; you can redistribute it and/or | ||
| 8 : | \ modify it under the terms of the GNU General Public License | ||
| 9 : | \ as published by the Free Software Foundation; either version 2 | ||
| 10 : | \ of the License, or (at your option) any later version. | ||
| 11 : | |||
| 12 : | \ This program is distributed in the hope that it will be useful, | ||
| 13 : | \ but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 14 : | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 15 : | \ GNU General Public License for more details. | ||
| 16 : | |||
| 17 : | \ You should have received a copy of the GNU General Public License | ||
| 18 : | \ along with this program; if not, write to the Free Software | ||
| 19 : | anton | 1.29 | \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
| 20 : | anton | 1.1 | |
| 21 : | \ Idea and implementation: Bernd Paysan (py) | ||
| 22 : | |||
| 23 : | jwilke | 1.16 | \ Needs: |
| 24 : | |||
| 25 : | require ./vars.fs | ||
| 26 : | anton | 1.32 | require ../compat/strcomp.fs |
| 27 : | jwilke | 1.16 | |
| 28 : | hex | ||
| 29 : | anton | 1.1 | |
| 30 : | \ labels for some code addresses | ||
| 31 : | |||
| 32 : | \- NIL NIL AConstant NIL \ gforth | ||
| 33 : | |||
| 34 : | \ Aliases | ||
| 35 : | |||
| 36 : | jwilke | 1.4 | [IFUNDEF] r@ |
| 37 : | anton | 1.1 | ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch |
| 38 : | jwilke | 1.4 | [THEN] |
| 39 : | anton | 1.1 | |
| 40 : | \ !! this is machine-dependent, but works on all but the strangest machines | ||
| 41 : | |||
| 42 : | anton | 1.23 | : maxaligned ( addr1 -- addr2 ) \ gforth |
| 43 : | \G @i{addr2} is the first address after @i{addr1} that satisfies | ||
| 44 : | \G all alignment restrictions. | ||
| 45 : | anton | 1.1 | [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ; |
| 46 : | anton | 1.23 | \ !! machine-dependent and won't work if "0 >body" <> "0 >body |
| 47 : | \G maxaligned" | ||
| 48 : | anton | 1.1 | ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth |
| 49 : | anton | 1.23 | \G @i{addr2} is the first address after @i{addr1} that is aligned for |
| 50 : | \G a code field (i.e., such that the corresponding body is maxaligned). | ||
| 51 : | anton | 1.1 | |
| 52 : | : chars ( n1 -- n2 ) \ core | ||
| 53 : | anton | 1.23 | \G @i{n2} is the number of address units of @i{n1} chars."" |
| 54 : | anton | 1.1 | ; immediate |
| 55 : | |||
| 56 : | |||
| 57 : | \ : A! ( addr1 addr2 -- ) \ gforth | ||
| 58 : | \ dup relon ! ; | ||
| 59 : | \ : A, ( addr -- ) \ gforth | ||
| 60 : | \ here cell allot A! ; | ||
| 61 : | ' ! alias A! ( addr1 addr2 -- ) \ gforth | ||
| 62 : | |||
| 63 : | anton | 1.2 | \ UNUSED 17may93jaw |
| 64 : | |||
| 65 : | pazsan | 1.41 | has? ec [IF] |
| 66 : | jwilke | 1.30 | unlock ram-dictionary borders nip lock |
| 67 : | AConstant dictionary-end | ||
| 68 : | jwilke | 1.4 | [ELSE] |
| 69 : | pazsan | 1.35 | has? header [IF] |
| 70 : | : dictionary-end ( -- addr ) | ||
| 71 : | forthstart [ 3 cells image-header + ] Aliteral @ + ; | ||
| 72 : | [ELSE] | ||
| 73 : | : forthstart 0 ; | ||
| 74 : | : dictionary-end ( -- addr ) | ||
| 75 : | forthstart [ has? kernel-size ] Literal + ; | ||
| 76 : | [THEN] | ||
| 77 : | jwilke | 1.4 | [THEN] |
| 78 : | anton | 1.2 | |
| 79 : | anton | 1.14 | : usable-dictionary-end ( -- addr ) |
| 80 : | dictionary-end [ word-pno-size pad-minsize + ] Literal - ; | ||
| 81 : | |||
| 82 : | anton | 1.2 | : unused ( -- u ) \ core-ext |
| 83 : | crook | 1.13 | \G Return the amount of free space remaining (in address units) in |
| 84 : | \G the region addressed by @code{here}. | ||
| 85 : | anton | 1.14 | usable-dictionary-end here - ; |
| 86 : | anton | 1.2 | |
| 87 : | pazsan | 1.40 | has? ec [IF] |
| 88 : | : in-dictionary? ( x -- f ) | ||
| 89 : | pazsan | 1.41 | dictionary-end u< ; |
| 90 : | pazsan | 1.40 | [ELSE] |
| 91 : | anton | 1.34 | : in-dictionary? ( x -- f ) |
| 92 : | forthstart dictionary-end within ; | ||
| 93 : | pazsan | 1.40 | [THEN] |
| 94 : | anton | 1.34 | |
| 95 : | anton | 1.1 | \ here is used for pad calculation! |
| 96 : | |||
| 97 : | : dp ( -- addr ) \ gforth | ||
| 98 : | dpp @ ; | ||
| 99 : | crook | 1.13 | : here ( -- addr ) \ core |
| 100 : | \G Return the address of the next free location in data space. | ||
| 101 : | anton | 1.1 | dp @ ; |
| 102 : | |||
| 103 : | \ on off 23feb93py | ||
| 104 : | |||
| 105 : | jwilke | 1.4 | \ on is used by docol: |
| 106 : | crook | 1.15 | : on ( a-addr -- ) \ gforth |
| 107 : | \G Set the (value of the) variable at @i{a-addr} to @code{true}. | ||
| 108 : | anton | 1.1 | true swap ! ; |
| 109 : | crook | 1.15 | : off ( a-addr -- ) \ gforth |
| 110 : | \G Set the (value of the) variable at @i{a-addr} to @code{false}. | ||
| 111 : | anton | 1.1 | false swap ! ; |
| 112 : | |||
| 113 : | \ dabs roll 17may93jaw | ||
| 114 : | |||
| 115 : | anton | 1.24 | : dabs ( d -- ud ) \ double d-abs |
| 116 : | anton | 1.1 | dup 0< IF dnegate THEN ; |
| 117 : | |||
| 118 : | : roll ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext | ||
| 119 : | anton | 1.47 | \ dup 1+ pick >r |
| 120 : | \ cells sp@ cell+ dup cell+ rot move drop r> ; | ||
| 121 : | dup 0<= if | ||
| 122 : | drop | ||
| 123 : | else | ||
| 124 : | pazsan | 1.54 | swap >r 1- recurse r> swap |
| 125 : | anton | 1.47 | then ; |
| 126 : | anton | 1.1 | |
| 127 : | \ place bounds 13feb93py | ||
| 128 : | |||
| 129 : | : place ( addr len to -- ) \ gforth | ||
| 130 : | over >r rot over 1+ r> move c! ; | ||
| 131 : | anton | 1.27 | : bounds ( addr u -- addr+u addr ) \ gforth |
| 132 : | \G Given a memory block represented by starting address @i{addr} | ||
| 133 : | \G and length @i{u} in aus, produce the end address @i{addr+u} and | ||
| 134 : | \G the start address in the right order for @code{u+do} or | ||
| 135 : | \G @code{?do}. | ||
| 136 : | anton | 1.1 | over + swap ; |
| 137 : | |||
| 138 : | \ (word) 22feb93py | ||
| 139 : | |||
| 140 : | : scan ( addr1 n1 char -- addr2 n2 ) \ gforth | ||
| 141 : | anton | 1.43 | \G skip all characters not equal to char |
| 142 : | anton | 1.1 | >r |
| 143 : | BEGIN | ||
| 144 : | dup | ||
| 145 : | WHILE | ||
| 146 : | over c@ r@ <> | ||
| 147 : | WHILE | ||
| 148 : | 1 /string | ||
| 149 : | REPEAT THEN | ||
| 150 : | rdrop ; | ||
| 151 : | : skip ( addr1 n1 char -- addr2 n2 ) \ gforth | ||
| 152 : | anton | 1.43 | \G skip all characters equal to char |
| 153 : | anton | 1.1 | >r |
| 154 : | BEGIN | ||
| 155 : | dup | ||
| 156 : | WHILE | ||
| 157 : | over c@ r@ = | ||
| 158 : | WHILE | ||
| 159 : | 1 /string | ||
| 160 : | REPEAT THEN | ||
| 161 : | rdrop ; | ||
| 162 : | |||
| 163 : | \ digit? 17dec92py | ||
| 164 : | |||
| 165 : | : digit? ( char -- digit true/ false ) \ gforth | ||
| 166 : | toupper [char] 0 - dup 9 u> IF | ||
| 167 : | jwilke | 1.16 | [ char A char 9 1 + - ] literal - |
| 168 : | anton | 1.1 | dup 9 u<= IF |
| 169 : | drop false EXIT | ||
| 170 : | THEN | ||
| 171 : | THEN | ||
| 172 : | dup base @ u>= IF | ||
| 173 : | drop false EXIT | ||
| 174 : | THEN | ||
| 175 : | true ; | ||
| 176 : | |||
| 177 : | : accumulate ( +d0 addr digit - +d1 addr ) | ||
| 178 : | pazsan | 1.40 | swap >r swap base @ um* drop rot base @ um* d+ r> ; |
| 179 : | anton | 1.1 | |
| 180 : | crook | 1.18 | : >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ core to-number |
| 181 : | anton | 1.22 | \G Attempt to convert the character string @var{c-addr1 u1} to an |
| 182 : | crook | 1.13 | \G unsigned number in the current number base. The double |
| 183 : | \G @var{ud1} accumulates the result of the conversion to form | ||
| 184 : | \G @var{ud2}. Conversion continues, left-to-right, until the whole | ||
| 185 : | \G string is converted or a character that is not convertable in | ||
| 186 : | \G the current number base is encountered (including + or -). For | ||
| 187 : | \G each convertable character, @var{ud1} is first multiplied by | ||
| 188 : | \G the value in @code{BASE} and then incremented by the value | ||
| 189 : | \G represented by the character. @var{c-addr2} is the location of | ||
| 190 : | \G the first unconverted character (past the end of the string if | ||
| 191 : | \G the whole string was converted). @var{u2} is the number of | ||
| 192 : | \G unconverted characters in the string. Overflow is not detected. | ||
| 193 : | anton | 1.1 | 0 |
| 194 : | ?DO | ||
| 195 : | count digit? | ||
| 196 : | WHILE | ||
| 197 : | accumulate | ||
| 198 : | LOOP | ||
| 199 : | 0 | ||
| 200 : | ELSE | ||
| 201 : | 1- I' I - | ||
| 202 : | UNLOOP | ||
| 203 : | THEN ; | ||
| 204 : | |||
| 205 : | \ s>d um/mod 21mar93py | ||
| 206 : | |||
| 207 : | : s>d ( n -- d ) \ core s-to-d | ||
| 208 : | dup 0< ; | ||
| 209 : | |||
| 210 : | : ud/mod ( ud1 u2 -- urem udquot ) \ gforth | ||
| 211 : | >r 0 r@ um/mod r> swap >r | ||
| 212 : | um/mod r> ; | ||
| 213 : | |||
| 214 : | \ catch throw 23feb93py | ||
| 215 : | |||
| 216 : | jwilke | 1.5 | has? glocals [IF] |
| 217 : | crook | 1.12 | : lp@ ( -- addr ) \ gforth lp-fetch |
| 218 : | anton | 1.1 | laddr# [ 0 , ] ; |
| 219 : | [THEN] | ||
| 220 : | |||
| 221 : | pazsan | 1.59 | has? os 0= [IF] |
| 222 : | pazsan | 1.52 | : catch ( ... xt -- ... 0 ) |
| 223 : | handler @ >r sp@ >r | ||
| 224 : | rp@ handler ! execute 0 r> drop r> handler ! ; | ||
| 225 : | : throw ( error -- error ) dup 0= IF drop EXIT THEN | ||
| 226 : | handler @ rp! r> swap >r sp! r> r> handler ! ; | ||
| 227 : | [ELSE] | ||
| 228 : | anton | 1.17 | defer catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception |
| 229 : | anton | 1.24 | \G @code{Executes} @i{xt}. If execution returns normally, |
| 230 : | \G @code{catch} pushes 0 on the stack. If execution returns through | ||
| 231 : | \G @code{throw}, all the stacks are reset to the depth on entry to | ||
| 232 : | \G @code{catch}, and the TOS (the @i{xt} position) is replaced with | ||
| 233 : | \G the throw code. | ||
| 234 : | |||
| 235 : | anton | 1.17 | :noname ( ... xt -- ... 0 ) |
| 236 : | execute 0 ; | ||
| 237 : | is catch | ||
| 238 : | anton | 1.1 | |
| 239 : | anton | 1.24 | defer throw ( y1 .. ym nerror -- y1 .. ym / z1 .. zn error ) \ exception |
| 240 : | \G If @i{nerror} is 0, drop it and continue. Otherwise, transfer | ||
| 241 : | \G control to the next dynamically enclosing exception handler, reset | ||
| 242 : | \G the stacks accordingly, and push @i{nerror}. | ||
| 243 : | |||
| 244 : | :noname ( y1 .. ym error -- y1 .. ym / z1 .. zn error ) | ||
| 245 : | anton | 1.19 | ?dup if |
| 246 : | pazsan | 1.35 | [ has? header [IF] here image-header 9 cells + ! [THEN] ] |
| 247 : | pazsan | 1.60 | cr DoError cr |
| 248 : | pazsan | 1.21 | [ has? file [IF] ] script? IF 1 (bye) ELSE quit THEN |
| 249 : | [ [ELSE] ] quit [ [THEN] ] | ||
| 250 : | anton | 1.19 | then ; |
| 251 : | pazsan | 1.56 | is throw |
| 252 : | pazsan | 1.52 | [THEN] |
| 253 : | anton | 1.19 | |
| 254 : | anton | 1.1 | \ (abort") |
| 255 : | |||
| 256 : | anton | 1.33 | : c(abort") ( c-addr -- ) |
| 257 : | "error ! -2 throw ; | ||
| 258 : | |||
| 259 : | anton | 1.1 | : (abort") |
| 260 : | "lit >r | ||
| 261 : | IF | ||
| 262 : | r> "error ! -2 throw | ||
| 263 : | THEN | ||
| 264 : | rdrop ; | ||
| 265 : | pazsan | 1.6 | |
| 266 : | : abort ( ?? -- ?? ) \ core,exception-ext | ||
| 267 : | crook | 1.12 | \G @code{-1 throw}. |
| 268 : | pazsan | 1.6 | -1 throw ; |
| 269 : | anton | 1.1 | |
| 270 : | \ ?stack 23feb93py | ||
| 271 : | |||
| 272 : | : ?stack ( ?? -- ?? ) \ gforth | ||
| 273 : | jwilke | 1.3 | sp@ sp0 @ u> IF -4 throw THEN |
| 274 : | jwilke | 1.5 | [ has? floating [IF] ] |
| 275 : | jwilke | 1.3 | fp@ fp0 @ u> IF -&45 throw THEN |
| 276 : | anton | 1.1 | [ [THEN] ] |
| 277 : | ; | ||
| 278 : | \ ?stack should be code -- it touches an empty stack! | ||
| 279 : | |||
| 280 : | \ DEPTH 9may93jaw | ||
| 281 : | |||
| 282 : | crook | 1.9 | : depth ( -- +n ) \ core depth |
| 283 : | crook | 1.12 | \G @var{+n} is the number of values that were on the data stack before |
| 284 : | \G @var{+n} itself was placed on the stack. | ||
| 285 : | jwilke | 1.3 | sp@ sp0 @ swap - cell / ; |
| 286 : | crook | 1.9 | |
| 287 : | : clearstack ( ... -- ) \ gforth clear-stack | ||
| 288 : | anton | 1.42 | \G remove and discard all/any items from the data stack. |
| 289 : | jwilke | 1.3 | sp0 @ sp! ; |
| 290 : | anton | 1.42 | |
| 291 : | : clearstacks ( ... -- ) \ gforth clear-stacks | ||
| 292 : | \G empty data and FP stack | ||
| 293 : | pazsan | 1.49 | clearstack |
| 294 : | [ has? floating [IF] ] | ||
| 295 : | fp0 @ fp! | ||
| 296 : | [ [THEN] ] | ||
| 297 : | ; | ||
| 298 : | anton | 1.1 | |
| 299 : | \ Strings 22feb93py | ||
| 300 : | |||
| 301 : | : "lit ( -- addr ) | ||
| 302 : | r> r> dup count + aligned >r swap >r ; | ||
| 303 : | |||
| 304 : | \ HEX DECIMAL 2may93jaw | ||
| 305 : | |||
| 306 : | : decimal ( -- ) \ core | ||
| 307 : | anton | 1.58 | \G Set @code{base} to &10 (decimal). Don't use @code{hex}, use |
| 308 : | \G @code{base-execute} instead. | ||
| 309 : | anton | 1.1 | a base ! ; |
| 310 : | : hex ( -- ) \ core-ext | ||
| 311 : | anton | 1.58 | \G Set @code{base} to &16 (hexadecimal). Don't use @code{hex}, |
| 312 : | \G use @code{base-execute} instead. | ||
| 313 : | anton | 1.1 | 10 base ! ; |
| 314 : |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |