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