Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ miscelleneous words |
| 2 : | |||
| 3 : | anton | 1.70 | \ Copyright (C) 1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011 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 : | anton | 1.57 | \ as published by the Free Software Foundation, either version 3 |
| 10 : | anton | 1.1 | \ 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 : | anton | 1.57 | \ along with this program. If not, see http://www.gnu.org/licenses/. |
| 19 : | anton | 1.1 | |
| 20 : | anton | 1.71 | : save-mem-dict ( addr1 u -- addr2 u ) |
| 21 : | here swap dup allot ( addr1 addr2 u ) | ||
| 22 : | 2dup 2>r move 2r> ; | ||
| 23 : | |||
| 24 : | ' usable-dictionary-end @ dodefer: = [if] | ||
| 25 : | require glocals.fs | ||
| 26 : | [else] | ||
| 27 : | require glocals-1.60.fs | ||
| 28 : | [then] | ||
| 29 : | |||
| 30 : | anton | 1.8 | |
| 31 : | anton | 1.6 | ' require alias needs ( ... "name" -- ... ) \ gforth |
| 32 : | crook | 1.11 | \G An alias for @code{require}; exists on other systems (e.g., Win32Forth). |
| 33 : | anton | 1.1 | \ needs is an F-PC name. we will probably switch to 'needs' in the future |
| 34 : | |||
| 35 : | \ a little more compiler security | ||
| 36 : | |||
| 37 : | \ currently not used by Gforth, but maybe by add-ons e.g., the 486asm | ||
| 38 : | AUser CSP | ||
| 39 : | |||
| 40 : | : !CSP ( -- ) | ||
| 41 : | sp@ csp ! ; | ||
| 42 : | |||
| 43 : | : ?CSP ( -- ) | ||
| 44 : | sp@ csp @ <> -22 and throw ; | ||
| 45 : | anton | 1.2 | |
| 46 : | anton | 1.4 | \ DMIN and DMAX |
| 47 : | |||
| 48 : | crook | 1.13 | : dmin ( d1 d2 -- d ) \ double d-min |
| 49 : | pazsan | 1.5 | 2over 2over d> IF 2swap THEN 2drop ; |
| 50 : | anton | 1.2 | |
| 51 : | crook | 1.13 | |
| 52 : | : dmax ( d1 d2 -- d ) \ double d-max | ||
| 53 : | pazsan | 1.5 | 2over 2over d< IF 2swap THEN 2drop ; |
| 54 : | anton | 1.4 | |
| 55 : | \ shell commands | ||
| 56 : | |||
| 57 : | crook | 1.10 | 0 Value $? ( -- n ) \ gforth dollar-question |
| 58 : | crook | 1.12 | \G @code{Value} -- the exit status returned by the most recently executed |
| 59 : | crook | 1.9 | \G @code{system} command. |
| 60 : | anton | 1.4 | |
| 61 : | anton | 1.14 | : system ( c-addr u -- ) \ gforth |
| 62 : | anton | 1.36 | \G Pass the string specified by @var{c-addr u} to the host operating |
| 63 : | \G system for execution in a sub-shell. The value of the environment | ||
| 64 : | \G variable @code{GFORTHSYSTEMPREFIX} (or its default value) is | ||
| 65 : | \G prepended to the string (mainly to support using @code{command.com} | ||
| 66 : | \G as shell in Windows instead of whatever shell Cygwin uses by | ||
| 67 : | \G default; @pxref{Environment variables}). | ||
| 68 : | anton | 1.4 | (system) throw TO $? ; |
| 69 : | crook | 1.9 | |
| 70 : | anton | 1.4 | : sh ( "..." -- ) \ gforth |
| 71 : | crook | 1.9 | \G Parse a string and use @code{system} to pass it to the host |
| 72 : | \G operating system for execution in a sub-shell. | ||
| 73 : | anton | 1.4 | '# parse cr system ; |
| 74 : | |||
| 75 : | anton | 1.8 | \ stuff |
| 76 : | |||
| 77 : | crook | 1.10 | : ]L ( compilation: n -- ; run-time: -- n ) \ gforth |
| 78 : | \G equivalent to @code{] literal} | ||
| 79 : | anton | 1.8 | ] postpone literal ; |
| 80 : | |||
| 81 : | anton | 1.23 | [ifundef] in-dictionary? |
| 82 : | anton | 1.8 | : in-dictionary? ( x -- f ) |
| 83 : | forthstart dictionary-end within ; | ||
| 84 : | anton | 1.23 | [endif] |
| 85 : | anton | 1.8 | |
| 86 : | : in-return-stack? ( addr -- f ) | ||
| 87 : | rp0 @ swap - [ forthstart 6 cells + ]L @ u< ; | ||
| 88 : | anton | 1.17 | |
| 89 : | \ const-does> | ||
| 90 : | |||
| 91 : | : compile-literals ( w*u u -- ; run-time: -- w*u ) recursive | ||
| 92 : | anton | 1.18 | \ compile u literals, starting with the bottommost one |
| 93 : | anton | 1.17 | ?dup-if |
| 94 : | swap >r 1- compile-literals | ||
| 95 : | r> POSTPONE literal | ||
| 96 : | endif ; | ||
| 97 : | |||
| 98 : | : compile-fliterals ( r*u u -- ; run-time: -- w*u ) recursive | ||
| 99 : | anton | 1.18 | \ compile u fliterals, starting with the bottommost one |
| 100 : | anton | 1.17 | ?dup-if |
| 101 : | { F: r } 1- compile-fliterals | ||
| 102 : | r POSTPONE fliteral | ||
| 103 : | endif ; | ||
| 104 : | |||
| 105 : | : (const-does>) ( w*uw r*ur uw ur target "name" -- ) | ||
| 106 : | anton | 1.18 | \ define a colon definition "name" containing w*uw r*ur as |
| 107 : | \ literals and a call to target. | ||
| 108 : | anton | 1.17 | { uw ur target } |
| 109 : | header docol: cfa, \ start colon def without stack junk | ||
| 110 : | ur compile-fliterals uw compile-literals | ||
| 111 : | target compile, POSTPONE exit reveal ; | ||
| 112 : | |||
| 113 : | anton | 1.35 | : const-does> ( run-time: w*uw r*ur uw ur "name" -- ) \ gforth |
| 114 : | \G Defines @var{name} and returns. | ||
| 115 : | \G | ||
| 116 : | anton | 1.18 | \G @var{name} execution: pushes @var{w*uw r*ur}, then performs the |
| 117 : | \G code following the @code{const-does>}. | ||
| 118 : | anton | 1.17 | here >r 0 POSTPONE literal |
| 119 : | POSTPONE (const-does>) | ||
| 120 : | POSTPONE ; | ||
| 121 : | noname : POSTPONE rdrop | ||
| 122 : | anton | 1.32 | latestxt r> cell+ ! \ patch the literal |
| 123 : | anton | 1.17 | ; immediate |
| 124 : | anton | 1.19 | |
| 125 : | anton | 1.20 | \ !! rewrite slurp-file using slurp-fid |
| 126 : | anton | 1.34 | : slurp-file ( c-addr1 u1 -- c-addr2 u2 ) \ gforth |
| 127 : | anton | 1.20 | \G @var{c-addr1 u1} is the filename, @var{c-addr2 u2} is the file's contents |
| 128 : | anton | 1.19 | r/o bin open-file throw >r |
| 129 : | r@ file-size throw abort" file too large" | ||
| 130 : | dup allocate throw swap | ||
| 131 : | 2dup r@ read-file throw over <> abort" could not read whole file" | ||
| 132 : | r> close-file throw ; | ||
| 133 : | |||
| 134 : | anton | 1.45 | : slurp-fid ( fid -- addr u ) \ gforth |
| 135 : | \G @var{addr u} is the content of the file @var{fid} | ||
| 136 : | { fid } | ||
| 137 : | anton | 1.20 | 0 0 begin ( awhole uwhole ) |
| 138 : | dup 1024 + dup >r extend-mem ( anew awhole uwhole R: unew ) | ||
| 139 : | rot r@ fid read-file throw ( awhole uwhole uread R: unew ) | ||
| 140 : | r> 2dup = | ||
| 141 : | while ( awhole uwhole uread unew ) | ||
| 142 : | 2drop | ||
| 143 : | repeat | ||
| 144 : | - + dup >r resize throw r> ; | ||
| 145 : | anton | 1.24 | |
| 146 : | anton | 1.25 | \ ]] ... [[ |
| 147 : | |||
| 148 : | pazsan | 1.69 | : [[ ( -- ) \ gforth left-bracket-bracket |
| 149 : | \G switch from postpone state to compile state | ||
| 150 : | \ this is only a marker; it is never really interpreted | ||
| 151 : | compile-only-error ; immediate | ||
| 152 : | |||
| 153 : | [ifdef] compiler1 | ||
| 154 : | anton | 1.25 | : compile-literal ( n -- ) |
| 155 : | postpone literal ; | ||
| 156 : | |||
| 157 : | anton | 1.42 | : compile-compile-literal ( n -- ) |
| 158 : | compile-literal postpone compile-literal ; | ||
| 159 : | |||
| 160 : | : compile-2literal ( n1 n2 -- ) | ||
| 161 : | postpone 2literal ; | ||
| 162 : | |||
| 163 : | : compile-compile-2literal ( n1 n2 -- ) | ||
| 164 : | compile-2literal postpone compile-2literal ; | ||
| 165 : | |||
| 166 : | : postponer1 ( c-addr u -- ... xt ) | ||
| 167 : | anton | 1.61 | 2dup find-name |
| 168 : | [ifdef] run-prelude run-prelude [then] | ||
| 169 : | anton | 1.60 | dup if ( c-addr u nt ) |
| 170 : | anton | 1.25 | nip nip name>comp |
| 171 : | 2dup [comp'] [[ d= if | ||
| 172 : | pazsan | 1.46 | 2drop ['] compiler1 is parser1 ['] noop |
| 173 : | anton | 1.25 | else |
| 174 : | anton | 1.42 | ['] postpone, |
| 175 : | anton | 1.25 | endif |
| 176 : | else | ||
| 177 : | drop | ||
| 178 : | anton | 1.42 | 2dup 2>r snumber? dup if |
| 179 : | anton | 1.25 | 0> IF |
| 180 : | anton | 1.42 | ['] compile-compile-2literal |
| 181 : | ELSE | ||
| 182 : | ['] compile-compile-literal | ||
| 183 : | anton | 1.25 | THEN |
| 184 : | anton | 1.42 | 2rdrop |
| 185 : | anton | 1.25 | ELSE |
| 186 : | anton | 1.42 | drop 2r> no.extensions |
| 187 : | anton | 1.25 | THEN |
| 188 : | then ; | ||
| 189 : | |||
| 190 : | anton | 1.63 | : ]] ( -- ) \ gforth right-bracket-bracket |
| 191 : | \G switch into postpone state | ||
| 192 : | anton | 1.42 | ['] postponer1 is parser1 state on ; immediate restrict |
| 193 : | pazsan | 1.68 | [then] |
| 194 : | |||
| 195 : | [ifdef] compiler-r | ||
| 196 : | : postponer-r ( addr u -- ... xt ) | ||
| 197 : | forth-recognizer do-recognizer | ||
| 198 : | over [ s" [[" find-name ] Literal = | ||
| 199 : | IF 2drop [comp'] ] drop ELSE ['] >postpone THEN ; | ||
| 200 : | |||
| 201 : | : ]] ( -- ) \ gforth right-bracket-bracket | ||
| 202 : | \G switch into postpone state | ||
| 203 : | ['] postponer-r is parser1 state on ; immediate restrict | ||
| 204 : | [then] | ||
| 205 : | anton | 1.43 | |
| 206 : | anton | 1.64 | comp' literal drop alias postpone-literal |
| 207 : | comp' 2literal drop alias postpone-2literal | ||
| 208 : | comp' fliteral drop alias postpone-fliteral | ||
| 209 : | comp' sliteral drop alias postpone-sliteral | ||
| 210 : | anton | 1.63 | |
| 211 : | : ]]L ( postponing: x -- ; compiling: -- x ) \ gforth right-bracket-bracket-l | ||
| 212 : | \G Shortcut for @code{]] literal}. | ||
| 213 : | ]] postpone-literal ]] [[ ; immediate | ||
| 214 : | |||
| 215 : | : ]]2L ( postponing: x1 x2 -- ; compiling: -- x1 x2 ) \ gforth right-bracket-bracket-two-l | ||
| 216 : | \G Shortcut for @code{]] 2literal}. | ||
| 217 : | ]] postpone-2literal ]] [[ ; immediate | ||
| 218 : | |||
| 219 : | : ]]FL ( postponing: r -- ; compiling: -- r ) \ gforth right-bracket-bracket-f-l | ||
| 220 : | \G Shortcut for @code{]] fliteral}. | ||
| 221 : | ]] postpone-fliteral ]] [[ ; immediate | ||
| 222 : | |||
| 223 : | : ]]SL ( postponing: addr1 u -- ; compiling: -- addr2 u ) \ gforth right-bracket-bracket-s-l | ||
| 224 : | \G Shortcut for @code{]] sliteral}; if the string already has been | ||
| 225 : | \G allocated permanently, you can use @code{]]2L} instead. | ||
| 226 : | ]] postpone-sliteral ]] [[ ; immediate | ||
| 227 : | |||
| 228 : | anton | 1.26 | \ f.rdp |
| 229 : | |||
| 230 : | anton | 1.27 | : push-right ( c-addr u1 u2 cfill -- ) |
| 231 : | anton | 1.26 | \ move string at c-addr u1 right by u2 chars (without exceeding |
| 232 : | \ the original bound); fill the gap with cfill | ||
| 233 : | anton | 1.27 | >r over min dup >r rot dup >r ( u1 u2 c-addr R: cfill u2 c-addr ) |
| 234 : | anton | 1.26 | dup 2swap /string cmove> |
| 235 : | r> r> r> fill ; | ||
| 236 : | |||
| 237 : | anton | 1.27 | : f>buf-rdp-try { f: rf c-addr ur nd up um1 -- um2 } |
| 238 : | \ um1 is the mantissa length to try, um2 is the actual mantissa length | ||
| 239 : | c-addr ur um1 /string '0 fill | ||
| 240 : | rf c-addr um1 represent if { nexp fsign } | ||
| 241 : | anton | 1.26 | nd nexp + up >= |
| 242 : | ur nd - 1- dup { beforep } fsign + nexp 0 max >= and if | ||
| 243 : | \ fixed-point notation | ||
| 244 : | anton | 1.27 | c-addr ur beforep nexp - dup { befored } '0 push-right |
| 245 : | anton | 1.44 | befored 1+ ur >= if \ <=1 digit left, will be pushed out by '.' |
| 246 : | rf fabs f2* 0.1e nd s>d d>f f** f> if \ round last digit | ||
| 247 : | '1 c-addr befored + 1- c! | ||
| 248 : | endif | ||
| 249 : | endif | ||
| 250 : | anton | 1.26 | c-addr beforep 1- befored min dup { beforez } 0 max bl fill |
| 251 : | fsign if | ||
| 252 : | '- c-addr beforez 1- 0 max + c! | ||
| 253 : | endif | ||
| 254 : | anton | 1.27 | c-addr ur beforep /string 1 '. push-right |
| 255 : | nexp nd + | ||
| 256 : | anton | 1.26 | else \ exponential notation |
| 257 : | anton | 1.27 | c-addr ur 1 /string 1 '. push-right |
| 258 : | anton | 1.26 | fsign if |
| 259 : | anton | 1.27 | c-addr ur 1 '- push-right |
| 260 : | anton | 1.26 | endif |
| 261 : | nexp 1- s>d tuck dabs <<# #s rot sign 'E hold #> { explen } | ||
| 262 : | anton | 1.27 | ur explen - 1- fsign + { mantlen } |
| 263 : | mantlen 0< if \ exponent too large | ||
| 264 : | anton | 1.26 | drop c-addr ur '* fill |
| 265 : | else | ||
| 266 : | c-addr ur + 0 explen negate /string move | ||
| 267 : | endif | ||
| 268 : | anton | 1.27 | #>> mantlen |
| 269 : | anton | 1.26 | endif |
| 270 : | else \ inf or nan | ||
| 271 : | if \ negative | ||
| 272 : | anton | 1.27 | c-addr ur 1 '- push-right |
| 273 : | anton | 1.26 | endif |
| 274 : | anton | 1.27 | drop ur |
| 275 : | anton | 1.26 | \ !! align in some way? |
| 276 : | anton | 1.27 | endif |
| 277 : | 1 max ur min ; | ||
| 278 : | |||
| 279 : | anton | 1.29 | : f>buf-rdp ( rf c-addr +nr +nd +np -- ) \ gforth |
| 280 : | anton | 1.28 | \G Convert @i{rf} into a string at @i{c-addr nr}. The conversion |
| 281 : | \G rules and the meanings of @i{nr nd np} are the same as for | ||
| 282 : | anton | 1.27 | \G @code{f.rdp}. |
| 283 : | \ first, get the mantissa length, then convert for real. The | ||
| 284 : | \ mantissa length is wrong in a few cases because of different | ||
| 285 : | \ rounding; In most cases this does not matter, because the | ||
| 286 : | \ mantissa is shorter than expected and the final digits are 0; | ||
| 287 : | \ but in a few cases the mantissa gets longer. Then it is | ||
| 288 : | \ conceivable that you will see a result that is rounded too much. | ||
| 289 : | \ However, I have not been able to construct an example where this | ||
| 290 : | \ leads to an unexpected result. | ||
| 291 : | swap 0 max swap 0 max | ||
| 292 : | fdup 2over 2over 2 pick f>buf-rdp-try f>buf-rdp-try drop ; | ||
| 293 : | anton | 1.26 | |
| 294 : | anton | 1.28 | : f>str-rdp ( rf +nr +nd +np -- c-addr nr ) \ gforth |
| 295 : | \G Convert @i{rf} into a string at @i{c-addr nr}. The conversion | ||
| 296 : | \G rules and the meanings of @i{nr +nd np} are the same as for | ||
| 297 : | anton | 1.26 | \G @code{f.rdp}. The result in in the pictured numeric output buffer |
| 298 : | \G and will be destroyed by anything destroying that buffer. | ||
| 299 : | anton | 1.28 | rot holdptr @ 1- 0 rot negate /string ( rf +nd np c-addr nr ) |
| 300 : | anton | 1.26 | over holdbuf u< -&17 and throw |
| 301 : | 2tuck 2>r f>buf-rdp 2r> ; | ||
| 302 : | |||
| 303 : | anton | 1.28 | : f.rdp ( rf +nr +nd +np -- ) \ gforth |
| 304 : | anton | 1.26 | \G Print float @i{rf} formatted. The total width of the output is |
| 305 : | anton | 1.30 | \G @i{nr}. For fixed-point notation, the number of digits after the |
| 306 : | \G decimal point is @i{+nd} and the minimum number of significant | ||
| 307 : | \G digits is @i{np}. @code{Set-precision} has no effect on | ||
| 308 : | \G @code{f.rdp}. Fixed-point notation is used if the number of | ||
| 309 : | \G siginicant digits would be at least @i{np} and if the number of | ||
| 310 : | \G digits before the decimal point would fit. If fixed-point notation | ||
| 311 : | \G is not used, exponential notation is used, and if that does not | ||
| 312 : | \G fit, asterisks are printed. We recommend using @i{nr}>=7 to avoid | ||
| 313 : | \G the risk of numbers not fitting at all. We recommend | ||
| 314 : | \G @i{nr}>=@i{np}+5 to avoid cases where @code{f.rdp} switches to | ||
| 315 : | \G exponential notation because fixed-point notation would have too | ||
| 316 : | \G few significant digits, yet exponential notation offers fewer | ||
| 317 : | \G significant digits. We recommend @i{nr}>=@i{nd}+2, if you want to | ||
| 318 : | \G have fixed-point notation for some numbers. We recommend | ||
| 319 : | \G @i{np}>@i{nr}, if you want to have exponential notation for all | ||
| 320 : | \G numbers. | ||
| 321 : | anton | 1.26 | f>str-rdp type ; |
| 322 : | |||
| 323 : | 0 [if] | ||
| 324 : | : testx ( rf ur nd up -- ) | ||
| 325 : | '| emit f.rdp ; | ||
| 326 : | |||
| 327 : | : test ( -- ) | ||
| 328 : | -0.123456789123456789e-20 | ||
| 329 : | 40 0 ?do | ||
| 330 : | cr | ||
| 331 : | fdup 7 3 1 testx | ||
| 332 : | fdup 7 3 4 testx | ||
| 333 : | fdup 7 3 0 testx | ||
| 334 : | fdup 7 7 1 testx | ||
| 335 : | fdup 7 5 1 testx | ||
| 336 : | fdup 7 0 2 testx | ||
| 337 : | fdup 5 2 1 testx | ||
| 338 : | fdup 4 2 1 testx | ||
| 339 : | fdup 18 8 5 testx | ||
| 340 : | '| emit | ||
| 341 : | 10e f* | ||
| 342 : | loop ; | ||
| 343 : | [then] | ||
| 344 : | anton | 1.33 | |
| 345 : | : f.s ( -- ) \ gforth f-dot-s | ||
| 346 : | anton | 1.51 | \G Display the number of items on the floating-point stack, followed |
| 347 : | \G by a list of the items (but not more than specified by | ||
| 348 : | \G @code{maxdepth-.s}; TOS is the right-most item. | ||
| 349 : | anton | 1.33 | ." <" fdepth 0 .r ." > " fdepth 0 max maxdepth-.s @ min dup 0 |
| 350 : | ?DO dup i - 1- floats fp@ + f@ 16 5 11 f.rdp space LOOP drop ; | ||
| 351 : | anton | 1.37 | |
| 352 : | \ defer stuff | ||
| 353 : | |||
| 354 : | pazsan | 1.39 | [ifundef] defer@ : defer@ >body @ ; [then] |
| 355 : | |||
| 356 : | anton | 1.37 | :noname ' defer@ ; |
| 357 : | :noname postpone ['] postpone defer@ ; | ||
| 358 : | interpret/compile: action-of ( interpretation "name" -- xt; compilation "name" -- ; run-time -- xt ) \ gforth | ||
| 359 : | \G @i{Xt} is the XT that is currently assigned to @i{name}. | ||
| 360 : | |||
| 361 : | ' action-of | ||
| 362 : | comp' action-of drop | ||
| 363 : | interpret/compile: what's ( interpretation "name" -- xt; compilation "name" -- ; run-time -- xt ) \ gforth-obsolete | ||
| 364 : | anton | 1.38 | \G Old name of @code{action-of} |
| 365 : | anton | 1.40 | |
| 366 : | |||
| 367 : | : typewhite ( addr n -- ) \ gforth | ||
| 368 : | \G Like type, but white space is printed instead of the characters. | ||
| 369 : | \ bounds u+do | ||
| 370 : | 0 max bounds ?do | ||
| 371 : | i c@ #tab = if \ check for tab | ||
| 372 : | #tab | ||
| 373 : | else | ||
| 374 : | bl | ||
| 375 : | then | ||
| 376 : | emit | ||
| 377 : | loop ; | ||
| 378 : | |||
| 379 : | anton | 1.49 | \ w and l stuff |
| 380 : | |||
| 381 : | environment-wordlist >order | ||
| 382 : | |||
| 383 : | anton | 1.50 | 16 address-unit-bits / 1 max constant /w ( -- u ) \ gforth slash-w |
| 384 : | anton | 1.49 | \G address units for a 16-bit value |
| 385 : | |||
| 386 : | anton | 1.50 | 32 address-unit-bits / 1 max constant /l ( -- u ) \ gforth slash-l |
| 387 : | anton | 1.49 | \G address units for a 32-bit value |
| 388 : | |||
| 389 : | previous | ||
| 390 : | anton | 1.48 | |
| 391 : | [ifdef] uw@ | ||
| 392 : | anton | 1.49 | \ Open firmware names |
| 393 : | anton | 1.48 | ' uw@ alias w@ ( addr -- u ) |
| 394 : | ' ul@ alias l@ ( addr -- u ) | ||
| 395 : | anton | 1.49 | \ ' sw@ alias <w@ ( addr -- n ) |
| 396 : | anton | 1.52 | [then] |
| 397 : | |||
| 398 : | \ safe output redirection | ||
| 399 : | |||
| 400 : | anton | 1.55 | : outfile-execute ( ... xt file-id -- ... ) \ gforth |
| 401 : | \G execute @i{xt} with the output of @code{type} etc. redirected to | ||
| 402 : | \G @i{file-id}. | ||
| 403 : | outfile-id { oldfid } try | ||
| 404 : | to outfile-id execute 0 | ||
| 405 : | restore | ||
| 406 : | oldfid to outfile-id | ||
| 407 : | endtry | ||
| 408 : | throw ; | ||
| 409 : | anton | 1.52 | |
| 410 : | anton | 1.55 | : infile-execute ( ... xt file-id -- ... ) \ gforth |
| 411 : | \G execute @i{xt} with the input of @code{key} etc. redirected to | ||
| 412 : | \G @i{file-id}. | ||
| 413 : | infile-id { oldfid } try | ||
| 414 : | to infile-id execute 0 | ||
| 415 : | restore | ||
| 416 : | oldfid to infile-id | ||
| 417 : | endtry | ||
| 418 : | throw ; | ||
| 419 : | anton | 1.52 | |
| 420 : | anton | 1.55 | \ safe BASE wrapper |
| 421 : | anton | 1.52 | |
| 422 : | anton | 1.55 | : base-execute ( i*x xt u -- j*x ) \ gforth |
| 423 : | \G execute @i{xt} with the content of @code{BASE} being @i{u}, and | ||
| 424 : | \G restoring the original @code{BASE} afterwards. | ||
| 425 : | base @ { oldbase } \ use local, because TRY blocks the return stack | ||
| 426 : | try | ||
| 427 : | base ! execute 0 | ||
| 428 : | restore | ||
| 429 : | oldbase base ! | ||
| 430 : | endtry | ||
| 431 : | throw ; | ||
| 432 : | anton | 1.52 | |
| 433 : | anton | 1.58 | \ th |
| 434 : | |||
| 435 : | : th ( addr1 u -- addr2 ) | ||
| 436 : | cells + ; | ||
| 437 : | pazsan | 1.62 | |
| 438 : | \ \\\ - skip to end of file | ||
| 439 : | |||
| 440 : | : \\\ ( -- ) \ gforth | ||
| 441 : | \G skip remaining source file | ||
| 442 : | source-id dup 0> IF | ||
| 443 : | >r r@ file-size throw r> reposition-file throw | ||
| 444 : | BEGIN refill 0= UNTIL postpone \ THEN ; immediate | ||
| 445 : | anton | 1.66 | |
| 446 : | \ WORD SWORD | ||
| 447 : | |||
| 448 : | : sword ( char -- addr len ) \ gforth-obsolete s-word | ||
| 449 : | \G Parses like @code{word}, but the output is like @code{parse} output. | ||
| 450 : | \G @xref{core-idef}. | ||
| 451 : | \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and | ||
| 452 : | \ dpANS6 A.6.2.2008 have a word with that name that behaves | ||
| 453 : | \ differently (like NAME). | ||
| 454 : | source 2dup >r >r >in @ over min /string | ||
| 455 : | rot dup bl = IF | ||
| 456 : | drop (parse-white) | ||
| 457 : | ELSE | ||
| 458 : | (word) | ||
| 459 : | THEN | ||
| 460 : | [ has? new-input [IF] ] | ||
| 461 : | 2dup input-lexeme! | ||
| 462 : | [ [THEN] ] | ||
| 463 : | 2dup + r> - 1+ r> min >in ! ; | ||
| 464 : | |||
| 465 : | : word ( char "<chars>ccc<char>-- c-addr ) \ core | ||
| 466 : | \G Skip leading delimiters. Parse @i{ccc}, delimited by | ||
| 467 : | \G @i{char}, in the parse area. @i{c-addr} is the address of a | ||
| 468 : | \G transient region containing the parsed string in | ||
| 469 : | \G counted-string format. If the parse area was empty or | ||
| 470 : | \G contained no characters other than delimiters, the resulting | ||
| 471 : | \G string has zero length. A program may replace characters within | ||
| 472 : | \G the counted string. OBSOLESCENT: the counted string has a | ||
| 473 : | \G trailing space that is not included in its length. | ||
| 474 : | sword here place bl here count + c! here ; | ||
| 475 : | anton | 1.72 | |
| 476 : | \ quotations | ||
| 477 : | |||
| 478 : | :noname false :noname ; | ||
| 479 : | :noname locals-wordlist last @ lastcfa @ | ||
| 480 : | postpone AHEAD | ||
| 481 : | locals-list @ locals-list off | ||
| 482 : | postpone SCOPE | ||
| 483 : | true :noname ; | ||
| 484 : | interpret/compile: [: ( compile-time: -- quotation-sys ) \ gforth bracket-colon | ||
| 485 : | \G Starts a quotation | ||
| 486 : | |||
| 487 : | : ;] ( compile-time: quotation-sys -- ; run-time: -- xt ) \ gforth semi-bracket | ||
| 488 : | \g ends a quotation | ||
| 489 : | POSTPONE ; >r IF | ||
| 490 : | ] postpone ENDSCOPE | ||
| 491 : | locals-list ! | ||
| 492 : | postpone THEN | ||
| 493 : | lastcfa ! last ! to locals-wordlist | ||
| 494 : | r> postpone ALiteral | ||
| 495 : | ELSE r> THEN ( xt ) ; immediate |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |