Annotation of gforth/kernel/nio.fs, revision 1.2
1.1 anton 1: \ Number IO
2:
3: \ Copyright (C) 1995-1997 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: : pad ( -- addr ) \ core-ext
1.2 ! anton 22: here word-pno-size + aligned ;
1.1 anton 23:
24: \ hold <# #> sign # #s 25jan92py
25:
26: : hold ( char -- ) \ core
27: pad cell - -1 chars over +! @ c! ;
28:
29: : <# ( -- ) \ core less-number-sign
30: pad cell - dup ! ;
31:
32: : #> ( xd -- addr u ) \ core number-sign-greater
33: 2drop pad cell - dup @ tuck - ;
34:
35: : sign ( n -- ) \ core
36: 0< IF [char] - hold THEN ;
37:
38: : # ( ud1 -- ud2 ) \ core number-sign
39: base @ 2 max ud/mod rot 9 over <
40: IF
41: [ char A char 9 - 1- ] Literal +
42: THEN
43: [char] 0 + hold ;
44:
45: : #s ( +d -- 0 0 ) \ core number-sign-s
46: BEGIN
47: # 2dup or 0=
48: UNTIL ;
49:
50: \ print numbers 07jun92py
51:
52: : d.r ( d n -- ) \ double d-dot-r
53: >r tuck dabs <# #s rot sign #>
54: r> over - spaces type ;
55:
56: : ud.r ( ud n -- ) \ gforth u-d-dot-r
57: >r <# #s #> r> over - spaces type ;
58:
59: : .r ( n1 n2 -- ) \ core-ext dot-r
60: >r s>d r> d.r ;
61: : u.r ( u n -- ) \ core-ext u-dot-r
62: 0 swap ud.r ;
63:
64: : d. ( d -- ) \ double d-dot
65: 0 d.r space ;
66: : ud. ( ud -- ) \ gforth u-d-dot
67: 0 ud.r space ;
68:
69: : . ( n -- ) \ core dot
70: s>d d. ;
71: : u. ( u -- ) \ core u-dot
72: 0 ud. ;
73:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>