Annotation of gforth/kernel/basics.fs, revision 1.1
1.1 ! anton 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: \ here is used for pad calculation!
! 52:
! 53: : dp ( -- addr ) \ gforth
! 54: dpp @ ;
! 55: : here ( -- here ) \ core
! 56: dp @ ;
! 57:
! 58: \ on off 23feb93py
! 59:
! 60: : on ( addr -- ) \ gforth
! 61: true swap ! ;
! 62: : off ( addr -- ) \ gforth
! 63: false swap ! ;
! 64:
! 65: \ dabs roll 17may93jaw
! 66:
! 67: : dabs ( d1 -- d2 ) \ double
! 68: dup 0< IF dnegate THEN ;
! 69:
! 70: : roll ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
! 71: dup 1+ pick >r
! 72: cells sp@ cell+ dup cell+ rot move drop r> ;
! 73:
! 74: \ place bounds 13feb93py
! 75:
! 76: : place ( addr len to -- ) \ gforth
! 77: over >r rot over 1+ r> move c! ;
! 78: : bounds ( beg count -- end beg ) \ gforth
! 79: over + swap ;
! 80:
! 81: \ (word) 22feb93py
! 82:
! 83: : scan ( addr1 n1 char -- addr2 n2 ) \ gforth
! 84: \ skip all characters not equal to char
! 85: >r
! 86: BEGIN
! 87: dup
! 88: WHILE
! 89: over c@ r@ <>
! 90: WHILE
! 91: 1 /string
! 92: REPEAT THEN
! 93: rdrop ;
! 94: : skip ( addr1 n1 char -- addr2 n2 ) \ gforth
! 95: \ skip all characters equal to char
! 96: >r
! 97: BEGIN
! 98: dup
! 99: WHILE
! 100: over c@ r@ =
! 101: WHILE
! 102: 1 /string
! 103: REPEAT THEN
! 104: rdrop ;
! 105:
! 106: \ digit? 17dec92py
! 107:
! 108: : digit? ( char -- digit true/ false ) \ gforth
! 109: base @ $100 =
! 110: IF
! 111: true EXIT
! 112: THEN
! 113: toupper [char] 0 - dup 9 u> IF
! 114: [ 'A '9 1 + - ] literal -
! 115: dup 9 u<= IF
! 116: drop false EXIT
! 117: THEN
! 118: THEN
! 119: dup base @ u>= IF
! 120: drop false EXIT
! 121: THEN
! 122: true ;
! 123:
! 124: : accumulate ( +d0 addr digit - +d1 addr )
! 125: swap >r swap base @ um* drop rot base @ um* d+ r> ;
! 126:
! 127: : >number ( d addr count -- d addr count ) \ core
! 128: 0
! 129: ?DO
! 130: count digit?
! 131: WHILE
! 132: accumulate
! 133: LOOP
! 134: 0
! 135: ELSE
! 136: 1- I' I -
! 137: UNLOOP
! 138: THEN ;
! 139:
! 140: \ s>d um/mod 21mar93py
! 141:
! 142: : s>d ( n -- d ) \ core s-to-d
! 143: dup 0< ;
! 144:
! 145: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
! 146: >r 0 r@ um/mod r> swap >r
! 147: um/mod r> ;
! 148:
! 149: \ catch throw 23feb93py
! 150: \ bounce 08jun93jaw
! 151:
! 152: \ !! allow the user to add rollback actions anton
! 153: \ !! use a separate exception stack? anton
! 154:
! 155: has-locals [IF]
! 156: : lp@ ( -- addr ) \ gforth l-p-fetch
! 157: laddr# [ 0 , ] ;
! 158: [THEN]
! 159:
! 160: \- 'catch Defer 'catch
! 161: \- 'throw Defer 'throw
! 162:
! 163: ' noop IS 'catch
! 164: ' noop IS 'throw
! 165:
! 166: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
! 167: 'catch
! 168: sp@ >r
! 169: [ has-floats [IF] ]
! 170: fp@ >r
! 171: [ [THEN] ]
! 172: [ has-locals [IF] ]
! 173: lp@ >r
! 174: [ [THEN] ]
! 175: handler @ >r
! 176: rp@ handler !
! 177: execute
! 178: r> handler ! rdrop rdrop rdrop 0 ;
! 179:
! 180: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
! 181: ?DUP IF
! 182: [ has-header [IF] here 9 cells ! [THEN] ] ] \ entry point for signal handler
! 183: [ has-interpreter [IF] ]
! 184: handler @ dup 0= IF
! 185: [ has-os [IF] ]
! 186: 2 (bye)
! 187: [ [ELSE] ]
! 188: quit
! 189: [ [THEN] ]
! 190: THEN
! 191: [ [THEN] ]
! 192: rp!
! 193: r> handler !
! 194: [ has-locals [IF] ]
! 195: r> lp!
! 196: [ [THEN] ]
! 197: [ has-floats [IF] ]
! 198: r> fp!
! 199: [ [THEN] ]
! 200: r> swap >r sp! drop r>
! 201: 'throw
! 202: THEN ;
! 203:
! 204: \ Bouncing is very fine,
! 205: \ programming without wasting time... jaw
! 206: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
! 207: \ a throw without data or fp stack restauration
! 208: ?DUP IF
! 209: handler @ rp!
! 210: r> handler !
! 211: [ has-locals [IF] ]
! 212: r> lp!
! 213: [ [THEN] ]
! 214: [ has-floats [IF] ]
! 215: rdrop
! 216: [ [THEN] ]
! 217: rdrop
! 218: 'throw
! 219: THEN ;
! 220:
! 221: \ (abort")
! 222:
! 223: : (abort")
! 224: "lit >r
! 225: IF
! 226: r> "error ! -2 throw
! 227: THEN
! 228: rdrop ;
! 229:
! 230: \ ?stack 23feb93py
! 231:
! 232: : ?stack ( ?? -- ?? ) \ gforth
! 233: sp@ s0 @ u> IF -4 throw THEN
! 234: [ has-floats [IF] ]
! 235: fp@ f0 @ u> IF -&45 throw THEN
! 236: [ [THEN] ]
! 237: ;
! 238: \ ?stack should be code -- it touches an empty stack!
! 239:
! 240: \ DEPTH 9may93jaw
! 241:
! 242: : depth ( -- +n ) \ core
! 243: sp@ s0 @ swap - cell / ;
! 244: : clearstack ( ... -- )
! 245: s0 @ sp! ;
! 246:
! 247: \ Strings 22feb93py
! 248:
! 249: : "lit ( -- addr )
! 250: r> r> dup count + aligned >r swap >r ;
! 251:
! 252: \ */MOD */ 17may93jaw
! 253:
! 254: \ !! I think */mod should have the same rounding behaviour as / - anton
! 255: : */mod ( n1 n2 n3 -- n4 n5 ) \ core star-slash-mod
! 256: >r m* r> sm/rem ;
! 257:
! 258: : */ ( n1 n2 n3 -- n4 ) \ core star-slash
! 259: */mod nip ;
! 260:
! 261: \ HEX DECIMAL 2may93jaw
! 262:
! 263: : decimal ( -- ) \ core
! 264: a base ! ;
! 265: : hex ( -- ) \ core-ext
! 266: 10 base ! ;
! 267:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to basics.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / kernel