--- gforth/see.fs 2003/01/04 08:26:57 1.47 +++ gforth/see.fs 2007/09/29 22:20:02 1.61 @@ -1,6 +1,6 @@ \ SEE.FS highend SEE for ANSforth 16may93jaw -\ Copyright (C) 1995,2000 Free Software Foundation, Inc. +\ Copyright (C) 1995,2000,2003,2004,2006 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -28,19 +28,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 +71,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 +120,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 @@ -278,12 +262,12 @@ VARIABLE C-Pass : .word ( addr x -- addr ) \ print x as a word if possible dup look 0= IF - drop dup threaded>name 0= if - 2drop dup 1 cells - @ dup body> look + drop dup threaded>name dup 0= if + 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 @@ -331,8 +315,9 @@ VARIABLE C-Pass cell+ ; : .name-without ( addr -- addr ) -\ prints a name without a() e.g. a(+LOOP) or (s") - dup 1 cells - @ threaded>name IF + \ !! the stack effect cannot be correct + \ prints a name without a() e.g. a(+LOOP) or (s") + dup 1 cells - @ threaded>name dup IF name>string over c@ 'a = IF 1 /string THEN @@ -358,8 +343,9 @@ VARIABLE C-Pass \ if f is false, addr2=addr1 \ recognizes the following patterns: \ c": ahead X: len string then lit X - \ s\": ahead X: string then lit X lit len - \ .\": ahead X: string then lit X lit len type + \ flit: ahead X: float then lit X f@ + \ s\": ahead X: string then lit X lit len + \ .\": ahead X: string then lit X lit len type \ !! not recognized anywhere: \ abort": if ahead X: len string then lit X c(abort") then dup @ back? if false exit endif @@ -367,8 +353,8 @@ VARIABLE C-Pass r@ @ decompile-prim ['] lit xt>threaded <> if rdrop false exit endif r@ cell+ @ over cell+ <> if rdrop false exit endif \ we have at least C" - r@ 2 cells + @ decompile-prim ['] lit xt>threaded = if - r@ 3 cells + @ over cell+ + aligned r@ = if + r@ 2 cells + @ decompile-prim dup ['] lit xt>threaded = if + drop r@ 3 cells + @ over cell+ + aligned r@ = if \ we have at least s" r@ 4 cells + @ decompile-prim ['] lit-perform xt>threaded = r@ 5 cells + @ ['] type >body = and if @@ -385,6 +371,12 @@ VARIABLE C-Pass nip cells r> + true exit endif endif + ['] f@ xt>threaded = if + display? if + r@ cell+ @ f@ 10 8 16 f>str-rdp 0 .string bl cemit + endif + drop r> 3 cells + true exit + endif \ !! check if count matches space? display? if s\" c\" " 0 .string r@ cell+ @ count 0 .string '" cemit bl cemit @@ -459,13 +451,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? @@ -499,7 +491,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? @@ -518,13 +510,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 @@ -675,13 +670,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 @@ -726,7 +723,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 @@ -761,6 +758,7 @@ Defer discode ( addr u -- ) \ gforth dup >code-address CASE docon: of seecon endof + dovalue: of seevalue endof docol: of seecol endof dovar: of seevar endof [ [IFDEF] douser: ] @@ -778,7 +776,7 @@ Defer discode ( addr u -- ) \ gforth ENDCASE ; : (xt-see-xt) ( xt -- ) - xt-see cr ." lastxt" ; + xt-see cr ." latestxt" ; ' (xt-see-xt) is xt-see-xt : (.immediate) ( xt -- ) @@ -799,7 +797,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 ;