gforth/kernel/basics.fs - view

File: [gforth] / gforth / kernel / basics.fs
Revision 1.8: download - view: text, annotated - select for diffs
Sun Jan 3 21:48:38 1999 UTC (25 years, 3 months ago) by anton
Branches: MAIN
CVS tags: HEAD

added ]L, IN-DICTIONARY? and IN-RETURN-STACK? to stuff.fs
refactored a few words to use IN-DICTIONARY?
added backtrace hooks to CATCH, THROW and (DOERROR)
added simple backtrace printing

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