Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ kernel.fs GForth kernel 17dec92py |
| 2 : | |||
| 3 : | \ Copyright (C) 1995 Free Software Foundation, Inc. | ||
| 4 : | |||
| 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 : | \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. | ||
| 20 : | |||
| 21 : | \ Idea and implementation: Bernd Paysan (py) | ||
| 22 : | |||
| 23 : | HEX | ||
| 24 : | |||
| 25 : | \ labels for some code addresses | ||
| 26 : | |||
| 27 : | \- NIL NIL AConstant NIL \ gforth | ||
| 28 : | |||
| 29 : | \ Aliases | ||
| 30 : | |||
| 31 : | ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch | ||
| 32 : | \G copy w from the return stack to the data stack | ||
| 33 : | |||
| 34 : | \ !! this is machine-dependent, but works on all but the strangest machines | ||
| 35 : | |||
| 36 : | : maxaligned ( addr -- f-addr ) \ float | ||
| 37 : | [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ; | ||
| 38 : | \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned" | ||
| 39 : | ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth | ||
| 40 : | |||
| 41 : | : chars ( n1 -- n2 ) \ core | ||
| 42 : | ; immediate | ||
| 43 : | |||
| 44 : | |||
| 45 : | \ : A! ( addr1 addr2 -- ) \ gforth | ||
| 46 : | \ dup relon ! ; | ||
| 47 : | \ : A, ( addr -- ) \ gforth | ||
| 48 : | \ here cell allot A! ; | ||
| 49 : | ' ! alias A! ( addr1 addr2 -- ) \ gforth | ||
| 50 : | |||
| 51 : | anton | 1.2 | \ UNUSED 17may93jaw |
| 52 : | |||
| 53 : | : dictionary-end ( -- addr ) | ||
| 54 : | forthstart [ 3 cells ] Aliteral @ + ; | ||
| 55 : | |||
| 56 : | : unused ( -- u ) \ core-ext | ||
| 57 : | dictionary-end here - [ word-pno-size pad-minsize + ] Literal - ; | ||
| 58 : | |||
| 59 : | anton | 1.1 | \ here is used for pad calculation! |
| 60 : | |||
| 61 : | : dp ( -- addr ) \ gforth | ||
| 62 : | dpp @ ; | ||
| 63 : | : here ( -- here ) \ core | ||
| 64 : | dp @ ; | ||
| 65 : | |||
| 66 : | \ on off 23feb93py | ||
| 67 : | |||
| 68 : | : on ( addr -- ) \ gforth | ||
| 69 : | true swap ! ; | ||
| 70 : | : off ( addr -- ) \ gforth | ||
| 71 : | false swap ! ; | ||
| 72 : | |||
| 73 : | \ dabs roll 17may93jaw | ||
| 74 : | |||
| 75 : | : dabs ( d1 -- d2 ) \ double | ||
| 76 : | dup 0< IF dnegate THEN ; | ||
| 77 : | |||
| 78 : | : roll ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext | ||
| 79 : | dup 1+ pick >r | ||
| 80 : | cells sp@ cell+ dup cell+ rot move drop r> ; | ||
| 81 : | |||
| 82 : | \ place bounds 13feb93py | ||
| 83 : | |||
| 84 : | : place ( addr len to -- ) \ gforth | ||
| 85 : | over >r rot over 1+ r> move c! ; | ||
| 86 : | : bounds ( beg count -- end beg ) \ gforth | ||
| 87 : | over + swap ; | ||
| 88 : | |||
| 89 : | \ (word) 22feb93py | ||
| 90 : | |||
| 91 : | : scan ( addr1 n1 char -- addr2 n2 ) \ gforth | ||
| 92 : | \ skip all characters not equal to char | ||
| 93 : | >r | ||
| 94 : | BEGIN | ||
| 95 : | dup | ||
| 96 : | WHILE | ||
| 97 : | over c@ r@ <> | ||
| 98 : | WHILE | ||
| 99 : | 1 /string | ||
| 100 : | REPEAT THEN | ||
| 101 : | rdrop ; | ||
| 102 : | : skip ( addr1 n1 char -- addr2 n2 ) \ gforth | ||
| 103 : | \ skip all characters equal to char | ||
| 104 : | >r | ||
| 105 : | BEGIN | ||
| 106 : | dup | ||
| 107 : | WHILE | ||
| 108 : | over c@ r@ = | ||
| 109 : | WHILE | ||
| 110 : | 1 /string | ||
| 111 : | REPEAT THEN | ||
| 112 : | rdrop ; | ||
| 113 : | |||
| 114 : | \ digit? 17dec92py | ||
| 115 : | |||
| 116 : | : digit? ( char -- digit true/ false ) \ gforth | ||
| 117 : | base @ $100 = | ||
| 118 : | IF | ||
| 119 : | true EXIT | ||
| 120 : | THEN | ||
| 121 : | toupper [char] 0 - dup 9 u> IF | ||
| 122 : | [ 'A '9 1 + - ] literal - | ||
| 123 : | dup 9 u<= IF | ||
| 124 : | drop false EXIT | ||
| 125 : | THEN | ||
| 126 : | THEN | ||
| 127 : | dup base @ u>= IF | ||
| 128 : | drop false EXIT | ||
| 129 : | THEN | ||
| 130 : | true ; | ||
| 131 : | |||
| 132 : | : accumulate ( +d0 addr digit - +d1 addr ) | ||
| 133 : | swap >r swap base @ um* drop rot base @ um* d+ r> ; | ||
| 134 : | |||
| 135 : | : >number ( d addr count -- d addr count ) \ core | ||
| 136 : | 0 | ||
| 137 : | ?DO | ||
| 138 : | count digit? | ||
| 139 : | WHILE | ||
| 140 : | accumulate | ||
| 141 : | LOOP | ||
| 142 : | 0 | ||
| 143 : | ELSE | ||
| 144 : | 1- I' I - | ||
| 145 : | UNLOOP | ||
| 146 : | THEN ; | ||
| 147 : | |||
| 148 : | \ s>d um/mod 21mar93py | ||
| 149 : | |||
| 150 : | : s>d ( n -- d ) \ core s-to-d | ||
| 151 : | dup 0< ; | ||
| 152 : | |||
| 153 : | : ud/mod ( ud1 u2 -- urem udquot ) \ gforth | ||
| 154 : | >r 0 r@ um/mod r> swap >r | ||
| 155 : | um/mod r> ; | ||
| 156 : | |||
| 157 : | \ catch throw 23feb93py | ||
| 158 : | \ bounce 08jun93jaw | ||
| 159 : | |||
| 160 : | \ !! allow the user to add rollback actions anton | ||
| 161 : | \ !! use a separate exception stack? anton | ||
| 162 : | |||
| 163 : | has-locals [IF] | ||
| 164 : | : lp@ ( -- addr ) \ gforth l-p-fetch | ||
| 165 : | laddr# [ 0 , ] ; | ||
| 166 : | [THEN] | ||
| 167 : | |||
| 168 : | \- 'catch Defer 'catch | ||
| 169 : | \- 'throw Defer 'throw | ||
| 170 : | |||
| 171 : | ' noop IS 'catch | ||
| 172 : | ' noop IS 'throw | ||
| 173 : | |||
| 174 : | : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception | ||
| 175 : | 'catch | ||
| 176 : | sp@ >r | ||
| 177 : | [ has-floats [IF] ] | ||
| 178 : | fp@ >r | ||
| 179 : | [ [THEN] ] | ||
| 180 : | [ has-locals [IF] ] | ||
| 181 : | lp@ >r | ||
| 182 : | [ [THEN] ] | ||
| 183 : | handler @ >r | ||
| 184 : | rp@ handler ! | ||
| 185 : | execute | ||
| 186 : | jwilke | 1.3 | r> handler ! rdrop |
| 187 : | [ has-floats [IF] ] | ||
| 188 : | rdrop | ||
| 189 : | [ [THEN] ] | ||
| 190 : | [ has-locals [IF] ] | ||
| 191 : | rdrop | ||
| 192 : | [ [THEN] ] | ||
| 193 : | 0 ; | ||
| 194 : | anton | 1.1 | |
| 195 : | : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception | ||
| 196 : | ?DUP IF | ||
| 197 : | [ has-header [IF] here 9 cells ! [THEN] ] ] \ entry point for signal handler | ||
| 198 : | [ has-interpreter [IF] ] | ||
| 199 : | handler @ dup 0= IF | ||
| 200 : | [ has-os [IF] ] | ||
| 201 : | 2 (bye) | ||
| 202 : | [ [ELSE] ] | ||
| 203 : | quit | ||
| 204 : | [ [THEN] ] | ||
| 205 : | THEN | ||
| 206 : | [ [THEN] ] | ||
| 207 : | rp! | ||
| 208 : | r> handler ! | ||
| 209 : | [ has-locals [IF] ] | ||
| 210 : | r> lp! | ||
| 211 : | [ [THEN] ] | ||
| 212 : | [ has-floats [IF] ] | ||
| 213 : | r> fp! | ||
| 214 : | [ [THEN] ] | ||
| 215 : | r> swap >r sp! drop r> | ||
| 216 : | 'throw | ||
| 217 : | THEN ; | ||
| 218 : | |||
| 219 : | \ Bouncing is very fine, | ||
| 220 : | \ programming without wasting time... jaw | ||
| 221 : | : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth | ||
| 222 : | \ a throw without data or fp stack restauration | ||
| 223 : | ?DUP IF | ||
| 224 : | handler @ rp! | ||
| 225 : | r> handler ! | ||
| 226 : | [ has-locals [IF] ] | ||
| 227 : | r> lp! | ||
| 228 : | [ [THEN] ] | ||
| 229 : | [ has-floats [IF] ] | ||
| 230 : | rdrop | ||
| 231 : | [ [THEN] ] | ||
| 232 : | rdrop | ||
| 233 : | 'throw | ||
| 234 : | THEN ; | ||
| 235 : | |||
| 236 : | \ (abort") | ||
| 237 : | |||
| 238 : | : (abort") | ||
| 239 : | "lit >r | ||
| 240 : | IF | ||
| 241 : | r> "error ! -2 throw | ||
| 242 : | THEN | ||
| 243 : | rdrop ; | ||
| 244 : | |||
| 245 : | \ ?stack 23feb93py | ||
| 246 : | |||
| 247 : | : ?stack ( ?? -- ?? ) \ gforth | ||
| 248 : | jwilke | 1.3 | sp@ sp0 @ u> IF -4 throw THEN |
| 249 : | anton | 1.1 | [ has-floats [IF] ] |
| 250 : | jwilke | 1.3 | fp@ fp0 @ u> IF -&45 throw THEN |
| 251 : | anton | 1.1 | [ [THEN] ] |
| 252 : | ; | ||
| 253 : | \ ?stack should be code -- it touches an empty stack! | ||
| 254 : | |||
| 255 : | \ DEPTH 9may93jaw | ||
| 256 : | |||
| 257 : | : depth ( -- +n ) \ core | ||
| 258 : | jwilke | 1.3 | sp@ sp0 @ swap - cell / ; |
| 259 : | anton | 1.1 | : clearstack ( ... -- ) |
| 260 : | jwilke | 1.3 | sp0 @ sp! ; |
| 261 : | anton | 1.1 | |
| 262 : | \ Strings 22feb93py | ||
| 263 : | |||
| 264 : | : "lit ( -- addr ) | ||
| 265 : | r> r> dup count + aligned >r swap >r ; | ||
| 266 : | |||
| 267 : | \ */MOD */ 17may93jaw | ||
| 268 : | |||
| 269 : | \ !! I think */mod should have the same rounding behaviour as / - anton | ||
| 270 : | : */mod ( n1 n2 n3 -- n4 n5 ) \ core star-slash-mod | ||
| 271 : | >r m* r> sm/rem ; | ||
| 272 : | |||
| 273 : | : */ ( n1 n2 n3 -- n4 ) \ core star-slash | ||
| 274 : | */mod nip ; | ||
| 275 : | |||
| 276 : | \ HEX DECIMAL 2may93jaw | ||
| 277 : | |||
| 278 : | : decimal ( -- ) \ core | ||
| 279 : | a base ! ; | ||
| 280 : | : hex ( -- ) \ core-ext | ||
| 281 : | 10 base ! ; | ||
| 282 : |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |