--- gforth/see.fs 2003/01/26 20:56:37 1.49 +++ gforth/see.fs 2010/05/02 16:58:02 1.72 @@ -1,12 +1,12 @@ \ SEE.FS highend SEE for ANSforth 16may93jaw -\ Copyright (C) 1995,2000 Free Software Foundation, Inc. +\ Copyright (C) 1995,2000,2003,2004,2006,2007,2008 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ 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. \ This program is distributed in the hope that it will be useful, @@ -15,8 +15,7 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. \ May be cross-compiled @@ -28,19 +27,6 @@ require look.fs require termsize.fs require wordinfo.fs -[IFUNDEF] .name -: id. ( nt -- ) \ gforth - \G Print the name of the word represented by @var{nt}. - \ this name comes from fig-Forth - name>string type space ; - -' id. alias .id ( nt -- ) -\G F83 name for @code{id.}. - -' id. alias .name ( nt -- ) -\G Gforth <=0.5.0 name for @code{id.}. - -[THEN] decimal @@ -84,13 +70,9 @@ DEFER nlcount ' noop IS nlcount nlflag @ IF (nl) nlflag off 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 -- ) 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 ELSE 2drop THEN ; @@ -137,9 +119,10 @@ VARIABLE Colors Colors on else base @ >r try 8 base ! 0 <<# # # # '\ hold #> ctype #>> 0 - recover + restore + r@ base ! endtry - r> base ! throw + rdrop throw endif endif 1 /string @@ -279,11 +262,11 @@ VARIABLE C-Pass \ print x as a word if possible dup look 0= IF drop dup threaded>name dup 0= if - 2drop dup 1 cells - @ dup body> look + drop over 1 cells - @ dup body> look IF - nip dup ." <" name>string rot wordinfo .string ." > " + nip nip dup ." <" name>string rot wordinfo .string ." > " ELSE - drop ." <" 0 .r ." > " + 2drop ." <" 0 .r ." > " THEN EXIT then @@ -310,6 +293,12 @@ VARIABLE C-Pass \ here docon: , docol: , dovar: , douser: , dodefer: , dofield: , \ 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 ) Display? IF dup @ dup body> dup cfaligned over = swap in-dictionary? and if @@ -318,6 +307,18 @@ VARIABLE C-Pass drop c-call EXIT 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 + [IFDEF] !;abi-code + over 2 cells + @ ['] !;abi-code >body = if drop + S" ;abi-code " Com# .string 4 cells + EXIT endif + [THEN] + endif + endif \ !! test for cfa here, and print "['] ..." dup abs 0 <# #S rot sign #> 0 .string bl cemit endif @@ -467,13 +468,13 @@ VARIABLE C-Pass THEN THEN Debug? - IF dup @ + + IF @ \ !!! cross-interacts with debugger !!! ELSE cell+ THEN ; : DebugBranch Debug? - IF dup @ over + swap THEN ; \ return 2 different addresses + IF dup @ swap THEN ; \ return 2 different addresses : c-?branch Scan? @@ -507,7 +508,7 @@ VARIABLE C-Pass Display? IF nl S" FOR" .struc level+ THEN ; : c-loop - Display? IF level- nl .name-without bl cemit nl THEN + Display? IF level- nl .name-without nl bl cemit THEN DebugBranch cell+ Scan? IF dup BranchAddr? @@ -526,13 +527,16 @@ VARIABLE C-Pass THEN DebugBranch cell+ ; -: c-exit dup 1 cells - - CheckEnd - IF Display? IF nlflag off S" ;" Com# .string THEN - C-Stop on - ELSE Display? IF S" EXIT " .struc THEN - THEN - Debug? IF drop THEN ; +: c-exit ( addr1 -- addr2 ) + dup 1 cells - + CheckEnd + IF + Display? IF nlflag off S" ;" Com# .string THEN + C-Stop on + ELSE + Display? IF S" EXIT " .struc THEN + THEN + Debug? IF drop THEN ; \ !!! cross-interacts with debugger !!! : c-abort" count 2dup + aligned -rot @@ -543,12 +547,6 @@ VARIABLE C-Pass ELSE 2drop THEN ; -[IFDEF] (does>) -: c-does> \ end of create part - Display? IF S" DOES> " Com# .string THEN - maxaligned /does-handler + ; -[THEN] - [IFDEF] (compile) : c-(compile) Display? @@ -590,7 +588,6 @@ CREATE C-Table [IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN] \ only defined if compiler is loaded [IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN] -[IFDEF] (does>) ' (does>) A, ' c-does> A, [THEN] 0 , here 0 , avariable c-extender @@ -671,7 +668,7 @@ Defer xt-see-xt ( xt -- ) space ; 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 : next-head ( addr1 -- addr2 ) \ gforth @@ -683,13 +680,15 @@ Defer discode ( addr u -- ) \ gforth cell +loop here ; +[ifundef] umin \ !! bootstrapping help : umin ( u1 u2 -- u ) 2dup u> if swap then drop ; - +[then] + : next-prim ( addr1 -- addr2 ) \ gforth \G find the next primitive after addr1 (unreliable) 1+ >r -1 primstart @@ -718,6 +717,11 @@ Defer discode ( addr u -- ) \ gforth then over - discode ." end-code" cr ; +: seeabicode ( xt -- ) + dup s" ABI-Code" .defname + >body dup dup next-head + swap - discode + ." end-code" cr ; : seevar ( xt -- ) s" Variable" .defname cr ; : seeuser ( xt -- ) @@ -734,7 +738,7 @@ Defer discode ( addr u -- ) \ gforth >name ?dup-if ." IS " .name cr else - ." lastxt >body !" + ." latestxt >body !" then ; : see-threaded ( addr -- ) C-Pass @ DebugMode = IF @@ -769,24 +773,30 @@ Defer discode ( addr u -- ) \ gforth dup >code-address CASE docon: of seecon endof +[IFDEF] dovalue: + dovalue: of seevalue endof +[THEN] docol: of seecol endof dovar: of seevar endof -[ [IFDEF] douser: ] +[IFDEF] douser: douser: of seeuser endof -[ [THEN] ] -[ [IFDEF] dodefer: ] +[THEN] +[IFDEF] dodefer: dodefer: of seedefer endof -[ [THEN] ] -[ [IFDEF] dofield: ] +[THEN] +[IFDEF] dofield: dofield: of seefield endof -[ [THEN] ] +[THEN] +[IFDEF] doabicode: + doabicode: of seeabicode endof +[THEN] over of seecode endof \ direct threaded code words over >body of seecode endof \ indirect threaded code words 2drop abort" unknown word type" ENDCASE ; : (xt-see-xt) ( xt -- ) - xt-see cr ." lastxt" ; + xt-see cr ." latestxt" ; ' (xt-see-xt) is xt-see-xt : (.immediate) ( xt -- ) @@ -807,7 +817,7 @@ Defer discode ( addr u -- ) \ gforth else \ interpret/compile word r@ xt-see-xt cr swap xt-see-xt cr - ." interpret/compile " over .name (.immediate) + ." interpret/compile: " over .name drop then then rdrop drop ;