version 1.60, 2007/02/18 18:30:51
|
version 1.73, 2010/08/28 09:48:53
|
Line 1
|
Line 1
|
\ SEE.FS highend SEE for ANSforth 16may93jaw |
\ SEE.FS highend SEE for ANSforth 16may93jaw |
|
|
\ Copyright (C) 1995,2000,2003,2004,2006 Free Software Foundation, Inc. |
\ Copyright (C) 1995,2000,2003,2004,2006,2007,2008 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
\ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
\ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
\ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
\ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
|
|
\ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
Line 15
|
Line 15
|
\ GNU General Public License for more details. |
\ GNU General Public License for more details. |
|
|
\ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
\ along with this program; if not, write to the Free Software |
\ along with this program. If not, see http://www.gnu.org/licenses/. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
|
|
|
\ May be cross-compiled |
\ May be cross-compiled |
Line 255 VARIABLE C-Pass
|
Line 254 VARIABLE C-Pass
|
: Scan? ( -- flag ) C-Pass @ 0= ; |
: Scan? ( -- flag ) C-Pass @ 0= ; |
: Display? ( -- flag ) C-Pass @ 1 = ; |
: Display? ( -- flag ) C-Pass @ 1 = ; |
: Debug? ( -- flag ) C-Pass @ 2 = ; |
: Debug? ( -- flag ) C-Pass @ 2 = ; |
|
: ?.string ( c-addr u n -- ) Display? if .string else 2drop drop then ; |
|
|
: back? ( addr target -- addr flag ) |
: back? ( addr target -- addr flag ) |
over u< ; |
over u< ; |
Line 294 VARIABLE C-Pass
|
Line 294 VARIABLE C-Pass
|
\ here docon: , docol: , dovar: , douser: , dodefer: , dofield: , |
\ here docon: , docol: , dovar: , douser: , dodefer: , dofield: , |
\ here over - 2constant doers |
\ here over - 2constant doers |
|
|
|
[IFDEF] !does |
|
: c-does> \ end of create part |
|
Display? IF S" DOES> " Com# .string THEN ; |
|
\ maxaligned /does-handler + ; \ !! no longer needed for non-cross stuff |
|
[THEN] |
|
|
: c-lit ( addr1 -- addr2 ) |
: c-lit ( addr1 -- addr2 ) |
Display? IF |
dup @ dup body> dup cfaligned over = swap in-dictionary? and if |
dup @ dup body> dup cfaligned over = swap in-dictionary? and if |
( addr1 addr1@ ) |
( addr1 addr1@ ) |
dup body> @ dovar: = if |
dup body> @ dovar: = if |
drop c-call EXIT |
drop c-call EXIT |
|
endif |
|
endif |
endif |
|
endif |
|
over 4 cells + over = if |
|
over 1 cells + @ decompile-prim ['] call xt>threaded = >r |
|
over 3 cells + @ decompile-prim ['] ;S xt>threaded = |
|
r> and if |
|
over 2 cells + @ ['] !does >body = if drop |
|
S" DOES> " Com# ?.string 4 cells + EXIT endif |
|
endif |
|
[IFDEF] !;abi-code |
|
over 2 cells + @ ['] !;abi-code >body = if drop |
|
S" ;abi-code " Com# ?.string 4 cells + |
|
c-stop on |
|
EXIT |
|
endif |
|
[THEN] |
|
endif |
|
Display? if |
\ !! test for cfa here, and print "['] ..." |
\ !! test for cfa here, and print "['] ..." |
dup abs 0 <# #S rot sign #> 0 .string bl cemit |
dup abs 0 <# #S rot sign #> 0 .string bl cemit |
endif |
else drop then |
cell+ ; |
cell+ ; |
|
|
: c-lit+ ( addr1 -- addr2 ) |
: c-lit+ ( addr1 -- addr2 ) |
Line 530 VARIABLE C-Pass
|
Line 551 VARIABLE C-Pass
|
ELSE 2drop |
ELSE 2drop |
THEN ; |
THEN ; |
|
|
[IFDEF] (does>) |
|
: c-does> \ end of create part |
|
Display? IF S" DOES> " Com# .string THEN |
|
maxaligned /does-handler + ; |
|
[THEN] |
|
|
|
[IFDEF] (compile) |
[IFDEF] (compile) |
: c-(compile) |
: c-(compile) |
Display? |
Display? |
Line 577 CREATE C-Table
|
Line 592 CREATE C-Table
|
[IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN] |
[IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN] |
\ only defined if compiler is loaded |
\ only defined if compiler is loaded |
[IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN] |
[IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN] |
[IFDEF] (does>) ' (does>) A, ' c-does> A, [THEN] |
|
0 , here 0 , |
0 , here 0 , |
|
|
avariable c-extender |
avariable c-extender |
Line 658 Defer xt-see-xt ( xt -- )
|
Line 672 Defer xt-see-xt ( xt -- )
|
space ; |
space ; |
|
|
Defer discode ( addr u -- ) \ gforth |
Defer discode ( addr u -- ) \ gforth |
\G hook for the disassembler: disassemble code at addr of length u |
\G hook for the disassembler: disassemble u bytes of code at addr |
' dump IS discode |
' dump IS discode |
|
|
: next-head ( addr1 -- addr2 ) \ gforth |
: next-head ( addr1 -- addr2 ) \ gforth |
Line 707 Defer discode ( addr u -- ) \ gforth
|
Line 721 Defer discode ( addr u -- ) \ gforth
|
then |
then |
over - discode |
over - discode |
." end-code" cr ; |
." end-code" cr ; |
|
: seeabicode ( xt -- ) |
|
dup s" ABI-Code" .defname |
|
>body dup dup next-head |
|
swap - discode |
|
." end-code" cr ; |
: seevar ( xt -- ) |
: seevar ( xt -- ) |
s" Variable" .defname cr ; |
s" Variable" .defname cr ; |
: seeuser ( xt -- ) |
: seeuser ( xt -- ) |
Line 758 Defer discode ( addr u -- ) \ gforth
|
Line 777 Defer discode ( addr u -- ) \ gforth
|
dup >code-address |
dup >code-address |
CASE |
CASE |
docon: of seecon endof |
docon: of seecon endof |
|
[IFDEF] dovalue: |
|
dovalue: of seevalue endof |
|
[THEN] |
docol: of seecol endof |
docol: of seecol endof |
dovar: of seevar endof |
dovar: of seevar endof |
[ [IFDEF] douser: ] |
[IFDEF] douser: |
douser: of seeuser endof |
douser: of seeuser endof |
[ [THEN] ] |
[THEN] |
[ [IFDEF] dodefer: ] |
[IFDEF] dodefer: |
dodefer: of seedefer endof |
dodefer: of seedefer endof |
[ [THEN] ] |
[THEN] |
[ [IFDEF] dofield: ] |
[IFDEF] dofield: |
dofield: of seefield endof |
dofield: of seefield endof |
[ [THEN] ] |
[THEN] |
|
[IFDEF] doabicode: |
|
doabicode: of seeabicode endof |
|
[THEN] |
over of seecode endof \ direct threaded code words |
over of seecode endof \ direct threaded code words |
over >body of seecode endof \ indirect threaded code words |
over >body of seecode endof \ indirect threaded code words |
2drop abort" unknown word type" |
2drop abort" unknown word type" |