--- gforth/see.fs 2006/05/07 18:14:11 1.57 +++ gforth/see.fs 2010/12/31 18:09:02 1.76 @@ -1,12 +1,12 @@ \ SEE.FS highend SEE for ANSforth 16may93jaw -\ Copyright (C) 1995,2000,2003,2004 Free Software Foundation, Inc. +\ Copyright (C) 1995,2000,2003,2004,2006,2007,2008,2010 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 @@ -71,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 ; @@ -86,6 +81,58 @@ DEFER nlcount ' noop IS nlcount IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN THEN ; + +Defer xt-see-xt ( xt -- ) +\ this one is just a forward declaration for indirect recursion + +: .defname ( xt c-addr u -- ) + rot look + if ( c-addr u nfa ) + -rot type space .name + else + drop ." noname " type + then + space ; + +Defer discode ( addr u -- ) \ gforth +\G hook for the disassembler: disassemble u bytes of code at addr +' dump IS discode + +: next-head ( addr1 -- addr2 ) \ gforth + \G find the next header starting after addr1, up to here (unreliable). + here swap u+do + i head? -2 and if + i unloop exit + then + 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 + begin ( umin head R: boundary ) + @ dup + while + tuck name>int >code-address ( head1 umin ca R: boundary ) + r@ - umin + swap + repeat + drop dup r@ negate u>= + \ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)" + if ( umin R: boundary ) \ no primitive found behind -> use a default length + drop 31 + then + r> + ; + DEFER .string ( c-addr u n -- ) [IFDEF] Green @@ -124,9 +171,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 @@ -258,6 +306,7 @@ VARIABLE C-Pass : Scan? ( -- flag ) C-Pass @ 0= ; : Display? ( -- flag ) C-Pass @ 1 = ; : Debug? ( -- flag ) C-Pass @ 2 = ; +: ?.string ( c-addr u n -- ) Display? if .string else 2drop drop then ; : back? ( addr target -- addr flag ) over u< ; @@ -297,17 +346,41 @@ 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 - ( addr1 addr1@ ) - dup body> @ dovar: = if - drop c-call EXIT - endif + dup @ dup body> dup cfaligned over = swap in-dictionary? and if + ( addr1 addr1@ ) + dup body> @ dovar: = if + 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 endif + [IFDEF] !;abi-code + over 2 cells + @ ['] !;abi-code >body = if drop + S" ;abi-code " Com# ?.string 4 cells + + c-stop on + Display? if + dup dup next-head over - discode + S" end-code" Com# ?.string + then EXIT + endif + [THEN] + endif + Display? if \ !! test for cfa here, and print "['] ..." dup abs 0 <# #S rot sign #> 0 .string bl cemit - endif + else drop then cell+ ; : c-lit+ ( addr1 -- addr2 ) @@ -445,10 +518,10 @@ VARIABLE C-Pass ELSE dup cell+ BranchAddr? Forward? IF dup cell+ @ WhileCode2 = - IF nl S" ELSE" .struc level+ + IF nl S" ELSE " .struc level+ ELSE level- nl S" ELSE" .struc level+ THEN cell+ Disable swap ! - ELSE S" AHEAD" .struc level+ + ELSE S" AHEAD " .struc level+ THEN THEN THEN @@ -533,12 +606,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? @@ -580,7 +647,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 @@ -648,57 +714,6 @@ c-extender ! c-stop @ UNTIL drop ; -Defer xt-see-xt ( xt -- ) -\ this one is just a forward declaration for indirect recursion - -: .defname ( xt c-addr u -- ) - rot look - if ( c-addr u nfa ) - -rot type space .name - else - drop ." noname " type - then - space ; - -Defer discode ( addr u -- ) \ gforth -\G hook for the disassembler: disassemble code at addr of length u -' dump IS discode - -: next-head ( addr1 -- addr2 ) \ gforth - \G find the next header starting after addr1, up to here (unreliable). - here swap u+do - i head? -2 and if - i unloop exit - then - 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 - begin ( umin head R: boundary ) - @ dup - while - tuck name>int >code-address ( head1 umin ca R: boundary ) - r@ - umin - swap - repeat - drop dup r@ negate u>= - \ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)" - if ( umin R: boundary ) \ no primitive found behind -> use a default length - drop 31 - then - r> + ; - : seecode ( xt -- ) dup s" Code" .defname >code-address @@ -710,6 +725,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 -- ) @@ -761,17 +781,23 @@ 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"