| \ number? number 23feb93py |
\ number? number 23feb93py |
| |
|
| hex |
hex |
| const Create bases 10 , 2 , A , 100 , |
const Create bases 0A , 10 , 2 , 0A , |
| \ 16 2 10 character |
\ 10 16 2 10 |
| |
|
| \ !! protect BASE saving wrapper against exceptions |
\ !! protect BASE saving wrapper against exceptions |
| : getbase ( addr u -- addr' u' ) |
: getbase ( addr u -- addr' u' ) |
| over c@ [char] $ - dup 4 u< |
2dup s" 0x" string-prefix? >r |
| |
2dup s" 0X" string-prefix? r> or |
| |
base @ #34 < and if |
| |
hex 2 /string |
| |
endif |
| |
over c@ [char] # - dup 4 u< |
| IF |
IF |
| cells bases + @ base ! 1 /string |
cells bases + @ base ! 1 /string |
| ELSE |
ELSE |
| THEN |
THEN |
| r> ; |
r> ; |
| |
|
| |
: s'>unumber? ( addr u -- ud flag ) |
| |
\ convert string "C" or "C'" to character code |
| |
dup 0= if |
| |
false exit |
| |
endif |
| |
over c@ >r |
| |
1 /string s" '" 2swap string-prefix? |
| |
r> 0 rot ; |
| |
|
| : s>unumber? ( addr u -- ud flag ) |
: s>unumber? ( addr u -- ud flag ) |
| |
over c@ '' = if |
| |
1 /string s'>unumber? exit |
| |
endif |
| base @ >r dpl on getbase |
base @ >r dpl on getbase |
| 0. 2swap |
0. 2swap |
| BEGIN ( d addr len ) |
BEGIN ( d addr len ) |
| \ \ DOERROR (DOERROR) 13jun93jaw |
\ \ DOERROR (DOERROR) 13jun93jaw |
| |
|
| 8 Constant max-errors |
8 Constant max-errors |
| |
4 has? file 2 and + Constant /error |
| Variable error-stack 0 error-stack ! |
Variable error-stack 0 error-stack ! |
| max-errors has? file [IF] 6 [ELSE] 4 [THEN] * cells allot |
max-errors /error * cells allot |
| \ format of one cell: |
\ format of one cell: |
| \ source ( addr u ) |
\ source ( addr u ) |
| \ >in |
\ >in |
| : error> ( -- addr u >in line# [addr u] ) |
: error> ( -- addr u >in line# [addr u] ) |
| -1 error-stack +! |
-1 error-stack +! |
| error-stack dup @ |
error-stack dup @ |
| [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+ |
/error * cells + cell+ |
| [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal cells bounds DO |
/error cells bounds DO |
| I @ |
I @ |
| cell +LOOP ; |
cell +LOOP ; |
| : >error ( addr u >in line# [addr u] -- ) |
: >error ( addr u >in line# [addr u] -- ) |
| error-stack dup @ dup 1+ |
error-stack dup @ dup 1+ |
| max-errors 1- min error-stack ! |
max-errors 1- min error-stack ! |
| [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+ |
/error * cells + cell+ |
| [ has? file [IF] 6 [ELSE] 4 [THEN] 1- ] Literal cells bounds swap DO |
/error 1- cells bounds swap DO |
| I ! |
I ! |
| -1 cells +LOOP ; |
-1 cells +LOOP ; |
| |
|
| \ !! not used... |
\ !! not used... |
| base @ decimal swap . base ! ; |
base @ decimal swap . base ! ; |
| |
|
| : dec.r ( u -- ) \ gforth |
: dec.r ( u n -- ) \ gforth |
| \G Display @i{u} as a unsigned decimal number |
\G Display @i{u} as a unsigned decimal number in a field @i{n} |
| base @ decimal swap 0 .r base ! ; |
\G characters wide. |
| |
base @ >r decimal .r r> base ! ; |
| |
|
| : hex. ( u -- ) \ gforth |
: hex. ( u -- ) \ gforth |
| \G Display @i{u} as an unsigned hex number, prefixed with a "$" and |
\G Display @i{u} as an unsigned hex number, prefixed with a "$" and |
| ELSE .error |
ELSE .error |
| THEN ; |
THEN ; |
| |
|
| |
: umin ( u1 u2 -- u ) |
| |
2dup u> |
| |
if |
| |
swap |
| |
then |
| |
drop ; |
| |
|
| |
Defer mark-start |
| |
Defer mark-end |
| |
|
| |
:noname ." >>>" ; IS mark-start |
| |
:noname ." <<<" ; IS mark-end |
| |
|
| |
: .error-line ( addr1 u1 n1 -- ) |
| |
\ print error ending at char n1 in line addr1 u1 |
| |
\ should work with UTF-8 (whitespace check looks ok) |
| |
over umin \ protect against wrong n1 |
| |
swap >r ( addr1 n1 R: u1 ) |
| |
-trailing 1- \ last non-space |
| |
0 >r BEGIN \ search for the first non-space |
| |
2dup + c@ bl > WHILE |
| |
r> 1+ >r 1- dup 0< UNTIL THEN 1+ |
| |
( addr1 n2 r: u1 namelen ) |
| |
2dup type mark-start |
| |
r> -rot r> swap /string ( namelen addr2 u2 ) |
| |
>r swap 2dup type mark-end ( addr2 namelen r: u2 ) |
| |
r> swap /string type ; |
| |
|
| : .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode ) |
: .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode ) |
| \ addr2 u2: filename of included file - optional |
\ addr2 u2: filename of included file - optional |
| \ n2: line number |
\ n2: line number |
| \ n1: error position in input line |
\ n1: error position in input line |
| \ addr1 u1: input line |
\ addr1 u1: input line |
| cr error-stack @ |
cr error-stack @ |
| IF |
IF ( throwcode addr1 u1 n1 n2 [addr2 u2] ) |
| [ has? file [IF] ] |
[ has? file [IF] ] \ !! unbalanced stack effect |
| ." in file included from " |
." in file included from " |
| type ." :" |
type ." :" |
| [ [THEN] ] |
[ [THEN] ] ( throwcode addr1 u1 n1 n2 ) |
| dec.r drop 2drop |
0 dec.r drop 2drop |
| ELSE |
ELSE ( throwcode addr1 u1 n1 n2 [addr2 u2] ) |
| [ has? file [IF] ] |
[ has? file [IF] ] |
| type ." :" |
type ." :" |
| [ [THEN] ] |
[ [THEN] ] ( throwcode addr1 u1 n1 n2 ) |
| dup >r dec.r ." : " 3 pick .error-string |
dup 0 dec.r ." : " 4 pick .error-string |
| r> IF \ if line# non-zero, there is a line |
IF \ if line# non-zero, there is a line |
| cr dup 2over type cr drop |
cr .error-line |
| nip -trailing 1- ( line-start index2 ) |
|
| 0 >r BEGIN |
|
| 2dup + c@ bl > WHILE |
|
| r> 1+ >r 1- dup 0< UNTIL THEN 1+ |
|
| ( line-start index1 ) |
|
| typewhite |
|
| r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 |
|
| [char] ^ emit |
|
| loop |
|
| ELSE |
ELSE |
| 2drop drop |
2drop drop |
| THEN |
THEN |
| [ has? os [IF] ] |
[ has? os [IF] ] |
| >stderr |
>stderr |
| [ [THEN] ] |
[ [THEN] ] |
| source >in @ sourceline# [ has? file [IF] ] |
source >in @ sourceline# [ has? file [IF] ] \ !! unbalanced stack effect |
| sourcefilename |
sourcefilename |
| [ [THEN] ] .error-frame |
[ [THEN] ] .error-frame |
| error-stack @ 0 ?DO |
error-stack @ 0 ?DO |
