version 1.57, 2006/05/07 18:14:11
|
version 1.60, 2007/02/18 18:30:51
|
Line 1
|
Line 1
|
\ SEE.FS highend SEE for ANSforth 16may93jaw |
\ SEE.FS highend SEE for ANSforth 16may93jaw |
|
|
\ Copyright (C) 1995,2000,2003,2004 Free Software Foundation, Inc. |
\ Copyright (C) 1995,2000,2003,2004,2006 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 71 DEFER nlcount ' noop IS nlcount
|
Line 71 DEFER nlcount ' noop IS nlcount
|
nlflag @ IF (nl) nlflag off THEN |
nlflag @ IF (nl) nlflag off THEN |
XPos @ over + cols u>= IF (nl) THEN ; |
XPos @ over + cols u>= IF (nl) THEN ; |
|
|
: c-to-upper ( c1 -- c2 ) \ gforth |
|
\ nac05feb1999 there is a primitive, toupper, with this function |
|
dup [char] a >= over [char] z <= and if bl - then ; |
|
|
|
: ctype ( adr len -- ) |
: ctype ( adr len -- ) |
warp? dup XPos +! C-Output @ |
warp? dup XPos +! C-Output @ |
IF uppercase @ IF bounds ?DO i c@ c-to-upper emit LOOP |
IF uppercase @ IF bounds ?DO i c@ toupper emit LOOP |
uppercase off ELSE type THEN |
uppercase off ELSE type THEN |
ELSE 2drop THEN ; |
ELSE 2drop THEN ; |
|
|
Line 124 VARIABLE Colors Colors on
|
Line 120 VARIABLE Colors Colors on
|
else |
else |
base @ >r try |
base @ >r try |
8 base ! 0 <<# # # # '\ hold #> ctype #>> 0 |
8 base ! 0 <<# # # # '\ hold #> ctype #>> 0 |
recover |
restore |
|
r@ base ! |
endtry |
endtry |
r> base ! throw |
rdrop throw |
endif |
endif |
endif |
endif |
1 /string |
1 /string |