Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ miscelleneous words |
| 2 : | |||
| 3 : | anton | 1.15 | \ Copyright (C) 1996,1997,1998,2000 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.16 | \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
| 20 : | anton | 1.1 | |
| 21 : | anton | 1.17 | require glocals.fs |
| 22 : | anton | 1.8 | |
| 23 : | anton | 1.6 | ' require alias needs ( ... "name" -- ... ) \ gforth |
| 24 : | crook | 1.11 | \G An alias for @code{require}; exists on other systems (e.g., Win32Forth). |
| 25 : | anton | 1.1 | \ needs is an F-PC name. we will probably switch to 'needs' in the future |
| 26 : | |||
| 27 : | \ a little more compiler security | ||
| 28 : | |||
| 29 : | \ currently not used by Gforth, but maybe by add-ons e.g., the 486asm | ||
| 30 : | AUser CSP | ||
| 31 : | |||
| 32 : | : !CSP ( -- ) | ||
| 33 : | sp@ csp ! ; | ||
| 34 : | |||
| 35 : | : ?CSP ( -- ) | ||
| 36 : | sp@ csp @ <> -22 and throw ; | ||
| 37 : | anton | 1.2 | |
| 38 : | anton | 1.4 | \ DMIN and DMAX |
| 39 : | |||
| 40 : | crook | 1.13 | : dmin ( d1 d2 -- d ) \ double d-min |
| 41 : | pazsan | 1.5 | 2over 2over d> IF 2swap THEN 2drop ; |
| 42 : | anton | 1.2 | |
| 43 : | crook | 1.13 | |
| 44 : | : dmax ( d1 d2 -- d ) \ double d-max | ||
| 45 : | pazsan | 1.5 | 2over 2over d< IF 2swap THEN 2drop ; |
| 46 : | anton | 1.4 | |
| 47 : | \ shell commands | ||
| 48 : | |||
| 49 : | crook | 1.10 | 0 Value $? ( -- n ) \ gforth dollar-question |
| 50 : | crook | 1.12 | \G @code{Value} -- the exit status returned by the most recently executed |
| 51 : | crook | 1.9 | \G @code{system} command. |
| 52 : | anton | 1.4 | |
| 53 : | anton | 1.14 | : system ( c-addr u -- ) \ gforth |
| 54 : | \G Pass the string specified by @var{c-addr u} to the host operating system | ||
| 55 : | crook | 1.9 | \G for execution in a sub-shell. |
| 56 : | anton | 1.4 | (system) throw TO $? ; |
| 57 : | crook | 1.9 | |
| 58 : | anton | 1.4 | : sh ( "..." -- ) \ gforth |
| 59 : | crook | 1.9 | \G Parse a string and use @code{system} to pass it to the host |
| 60 : | \G operating system for execution in a sub-shell. | ||
| 61 : | anton | 1.4 | '# parse cr system ; |
| 62 : | |||
| 63 : | anton | 1.8 | \ stuff |
| 64 : | |||
| 65 : | crook | 1.10 | : ]L ( compilation: n -- ; run-time: -- n ) \ gforth |
| 66 : | \G equivalent to @code{] literal} | ||
| 67 : | anton | 1.8 | ] postpone literal ; |
| 68 : | |||
| 69 : | anton | 1.23 | [ifundef] in-dictionary? |
| 70 : | anton | 1.8 | : in-dictionary? ( x -- f ) |
| 71 : | forthstart dictionary-end within ; | ||
| 72 : | anton | 1.23 | [endif] |
| 73 : | anton | 1.8 | |
| 74 : | : in-return-stack? ( addr -- f ) | ||
| 75 : | rp0 @ swap - [ forthstart 6 cells + ]L @ u< ; | ||
| 76 : | anton | 1.17 | |
| 77 : | \ const-does> | ||
| 78 : | |||
| 79 : | : compile-literals ( w*u u -- ; run-time: -- w*u ) recursive | ||
| 80 : | anton | 1.18 | \ compile u literals, starting with the bottommost one |
| 81 : | anton | 1.17 | ?dup-if |
| 82 : | swap >r 1- compile-literals | ||
| 83 : | r> POSTPONE literal | ||
| 84 : | endif ; | ||
| 85 : | |||
| 86 : | : compile-fliterals ( r*u u -- ; run-time: -- w*u ) recursive | ||
| 87 : | anton | 1.18 | \ compile u fliterals, starting with the bottommost one |
| 88 : | anton | 1.17 | ?dup-if |
| 89 : | { F: r } 1- compile-fliterals | ||
| 90 : | r POSTPONE fliteral | ||
| 91 : | endif ; | ||
| 92 : | |||
| 93 : | : (const-does>) ( w*uw r*ur uw ur target "name" -- ) | ||
| 94 : | anton | 1.18 | \ define a colon definition "name" containing w*uw r*ur as |
| 95 : | \ literals and a call to target. | ||
| 96 : | anton | 1.17 | { uw ur target } |
| 97 : | header docol: cfa, \ start colon def without stack junk | ||
| 98 : | ur compile-fliterals uw compile-literals | ||
| 99 : | target compile, POSTPONE exit reveal ; | ||
| 100 : | |||
| 101 : | : const-does> ( run-time: w*uw r*ur uw ur "name" -- ) | ||
| 102 : | anton | 1.18 | \G Defines @var{name} and returns.@sp 0 |
| 103 : | \G @var{name} execution: pushes @var{w*uw r*ur}, then performs the | ||
| 104 : | \G code following the @code{const-does>}. | ||
| 105 : | anton | 1.17 | here >r 0 POSTPONE literal |
| 106 : | POSTPONE (const-does>) | ||
| 107 : | POSTPONE ; | ||
| 108 : | noname : POSTPONE rdrop | ||
| 109 : | lastxt r> cell+ ! \ patch the literal | ||
| 110 : | ; immediate | ||
| 111 : | anton | 1.19 | |
| 112 : | anton | 1.20 | \ !! rewrite slurp-file using slurp-fid |
| 113 : | anton | 1.19 | : slurp-file ( c-addr1 u1 -- c-addr2 u2 ) |
| 114 : | anton | 1.20 | \G @var{c-addr1 u1} is the filename, @var{c-addr2 u2} is the file's contents |
| 115 : | anton | 1.19 | r/o bin open-file throw >r |
| 116 : | r@ file-size throw abort" file too large" | ||
| 117 : | dup allocate throw swap | ||
| 118 : | 2dup r@ read-file throw over <> abort" could not read whole file" | ||
| 119 : | r> close-file throw ; | ||
| 120 : | |||
| 121 : | anton | 1.20 | : slurp-fid { fid -- addr u } |
| 122 : | \G @var{addr u} is the content of the file @var{fid} | ||
| 123 : | 0 0 begin ( awhole uwhole ) | ||
| 124 : | dup 1024 + dup >r extend-mem ( anew awhole uwhole R: unew ) | ||
| 125 : | rot r@ fid read-file throw ( awhole uwhole uread R: unew ) | ||
| 126 : | r> 2dup = | ||
| 127 : | while ( awhole uwhole uread unew ) | ||
| 128 : | 2drop | ||
| 129 : | repeat | ||
| 130 : | - + dup >r resize throw r> ; | ||
| 131 : | anton | 1.24 | |
| 132 : | anton | 1.25 | \ ]] ... [[ |
| 133 : | |||
| 134 : | : compile-literal ( n -- ) | ||
| 135 : | postpone literal ; | ||
| 136 : | |||
| 137 : | : [[ ( -- ) | ||
| 138 : | \G switch from postpone state to compile state | ||
| 139 : | \ this is only a marker; it is never really interpreted | ||
| 140 : | compile-only-error ; immediate | ||
| 141 : | |||
| 142 : | : postponer ( c-addr u -- ) | ||
| 143 : | 2dup find-name dup if ( c-addr u nt ) | ||
| 144 : | nip nip name>comp | ||
| 145 : | 2dup [comp'] [[ d= if | ||
| 146 : | 2drop ['] compiler is parser | ||
| 147 : | else | ||
| 148 : | postpone, | ||
| 149 : | endif | ||
| 150 : | else | ||
| 151 : | drop | ||
| 152 : | 2dup snumber? dup if | ||
| 153 : | 0> IF | ||
| 154 : | swap postpone literal postpone compile-literal | ||
| 155 : | THEN | ||
| 156 : | postpone Literal postpone compile-literal | ||
| 157 : | 2drop | ||
| 158 : | ELSE | ||
| 159 : | drop no.extensions | ||
| 160 : | THEN | ||
| 161 : | then ; | ||
| 162 : | |||
| 163 : | : ]] ( -- ) | ||
| 164 : | \ switch into postpone state | ||
| 165 : | ['] postponer is parser state on ; immediate restrict | ||
| 166 : |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |