File:  [gforth] / gforth / see.fs
Revision 1.30: download - view: text, annotated - select for diffs
Sat Sep 23 15:06:02 2000 UTC (23 years, 6 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright dates in many files (not in ec-related files)

    1: \ SEE.FS       highend SEE for ANSforth                16may93jaw
    2: 
    3: \ Copyright (C) 1995,2000 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation; either version 2
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program; if not, write to the Free Software
   19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   20: 
   21: 
   22: \ May be cross-compiled
   23: 
   24: \ I'm sorry. This is really not "forthy" enough.
   25: 
   26: \ Ideas:        Level should be a stack
   27: 
   28: require look.fs
   29: require termsize.fs
   30: require wordinfo.fs
   31: [IFUNDEF] .name : .name name>string type space ; [THEN]
   32: 
   33: decimal
   34: 
   35: \ Screen format words                                   16may93jaw
   36: 
   37: VARIABLE C-Output   1 C-Output  !
   38: VARIABLE C-Formated 1 C-Formated !
   39: VARIABLE C-Highlight 0 C-Highlight !
   40: VARIABLE C-Clearline 0 C-Clearline !
   41: 
   42: VARIABLE XPos
   43: VARIABLE YPos
   44: VARIABLE Level
   45: 
   46: : Format        C-Formated @ C-Output @ and
   47:                 IF dup spaces XPos +! ELSE drop THEN ;
   48: 
   49: : level+        7 Level +!
   50:                 Level @ XPos @ -
   51:                 dup 0> IF Format ELSE drop THEN ;
   52: 
   53: : level-        -7 Level +! ;
   54: 
   55: VARIABLE nlflag
   56: VARIABLE uppercase	\ structure words are in uppercase
   57: 
   58: DEFER nlcount ' noop IS nlcount
   59: 
   60: : nl            nlflag on ;
   61: : (nl)          nlcount
   62:                 XPos @ Level @ = IF EXIT THEN \ ?Exit
   63:                 C-Formated @ IF
   64:                 C-Output @
   65:                 IF C-Clearline @ IF cols XPos @ - spaces
   66:                                  ELSE cr THEN
   67:                 1 YPos +! 0 XPos !
   68:                 Level @ spaces
   69:                 THEN Level @ XPos ! THEN ;
   70: 
   71: : warp?         ( len -- len )
   72:                 nlflag @ IF (nl) nlflag off THEN
   73:                 XPos @ over + cols u>= IF (nl) THEN ;
   74: 
   75: : c-to-upper ( c1 -- c2 ) \ gforth
   76:     \ nac05feb1999 there is a primitive, toupper, with this function
   77:     dup [char] a >= over [char] z <= and if  bl -  then ;
   78: 
   79: : ctype         ( adr len -- )
   80:                 warp? dup XPos +! C-Output @ 
   81: 		IF uppercase @ IF bounds ?DO i c@ c-to-upper emit LOOP
   82: 				  uppercase off ELSE type THEN
   83: 		ELSE 2drop THEN ;
   84: 
   85: : cemit         1 warp?
   86:                 over bl = Level @ XPos @ = and
   87:                 IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN
   88:                 THEN ;
   89: 
   90: DEFER .string
   91: 
   92: [IFDEF] Green
   93: VARIABLE Colors Colors on
   94: 
   95: : (.string)     ( c-addr u n -- )
   96:                 over warp? drop
   97:                 Colors @
   98:                 IF C-Highlight @ ?dup
   99:                    IF   CT@ swap CT@ or
  100:                    ELSE CT@
  101:                    THEN
  102:                 attr! ELSE drop THEN
  103:                 ctype  ct @ attr! ;
  104: [ELSE]
  105: : (.string)     ( c-addr u n -- )
  106:                 drop ctype ;
  107: [THEN]
  108: 
  109: ' (.string) IS .string
  110: 
  111: 
  112: : .struc        
  113: 	uppercase on Str# .string ;
  114: 
  115: \ CODES (Branchtypes)                                    15may93jaw
  116: 
  117: 21 CONSTANT RepeatCode
  118: 22 CONSTANT AgainCode
  119: 23 CONSTANT UntilCode
  120: \ 09 CONSTANT WhileCode
  121: 10 CONSTANT ElseCode
  122: 11 CONSTANT AheadCode
  123: 13 CONSTANT WhileCode2
  124: 14 CONSTANT Disable
  125: 15 CONSTANT LeaveCode
  126: 
  127: 
  128: \ FORMAT WORDS                                          13jun93jaw
  129: 
  130: VARIABLE C-Stop
  131: VARIABLE Branches
  132: 
  133: VARIABLE BranchPointer	\ point to the end of branch table
  134: VARIABLE SearchPointer
  135: 
  136: \ The branchtable consists of three entrys:
  137: \ address of branch , branch destination , branch type
  138: 
  139: CREATE BranchTable 128 cells allot
  140: here 3 cells -
  141: ACONSTANT MaxTable
  142: 
  143: : FirstBranch BranchTable cell+ SearchPointer ! ;
  144: 
  145: : (BranchAddr?) ( a-addr1 -- a-addr2 true | false )
  146: \ searches a branch with destination a-addr1
  147: \ a-addr1: branch destination
  148: \ a-addr2: pointer in branch table
  149:         SearchPointer @
  150:         BEGIN   dup BranchPointer @ u<
  151:         WHILE
  152:                 dup @ 2 pick <>
  153:         WHILE   3 cells +
  154:         REPEAT
  155:         nip dup  3 cells + SearchPointer ! true
  156:         ELSE
  157:         2drop false
  158:         THEN ;
  159: 
  160: : BranchAddr?
  161:         FirstBranch (BranchAddr?) ;
  162: 
  163: ' (BranchAddr?) ALIAS MoreBranchAddr?
  164: 
  165: : CheckEnd ( a-addr -- true | false )
  166:         BranchTable cell+
  167:         BEGIN   dup BranchPointer @ u<
  168:         WHILE
  169:                 dup @ 2 pick u<=
  170:         WHILE   3 cells +
  171:         REPEAT
  172:         2drop false
  173:         ELSE
  174:         2drop true
  175:         THEN ;
  176: 
  177: : MyBranch      ( a-addr -- a-addr a-addr2 )
  178: \ finds branch table entry for branch at a-addr
  179:                 dup @ over +
  180:                 BranchAddr?
  181:                 BEGIN
  182:                 WHILE 1 cells - @
  183:                       over <>
  184:                 WHILE dup @ over +
  185:                       MoreBranchAddr?
  186:                 REPEAT
  187:                 SearchPointer @ 3 cells -
  188:                 ELSE    true ABORT" SEE: Table failure"
  189:                 THEN ;
  190: 
  191: \
  192: \                 addrw               addrt
  193: \       BEGIN ... WHILE ... AGAIN ... THEN
  194: \         ^         !        !          ^
  195: \         ----------+--------+          !
  196: \                   !                   !
  197: \                   +-------------------+
  198: \
  199: \
  200: 
  201: : CheckWhile ( a-addrw a-addrt -- true | false )
  202:         BranchTable
  203:         BEGIN   dup BranchPointer @ u<
  204:         WHILE   dup @ 3 pick u>
  205:                 over @ 3 pick u< and
  206:                 IF dup cell+ @ 3 pick u<
  207:                         IF 2drop drop true EXIT THEN
  208:                 THEN
  209:                 3 cells +
  210:         REPEAT
  211:         2drop drop false ;
  212: 
  213: : ,Branch ( a-addr -- )
  214:         BranchPointer @ dup MaxTable u> ABORT" SEE: Table overflow"
  215:         !
  216:         1 cells BranchPointer +! ;
  217: 
  218: : Type!   ( u -- )
  219:         BranchPointer @ 1 cells - ! ;
  220: 
  221: : Branch! ( a-addr rel -- a-addr )
  222:         over + over ,Branch ,Branch 0 ,Branch ;
  223: 
  224: \ DEFER CheckUntil
  225: VARIABLE NoOutput
  226: VARIABLE C-Pass
  227: 
  228: 0 CONSTANT ScanMode
  229: 1 CONSTANT DisplayMode
  230: 2 CONSTANT DebugMode
  231: 
  232: : Scan? ( -- flag ) C-Pass @ 0= ;
  233: : Display? ( -- flag ) C-Pass @ 1 = ;
  234: : Debug? ( -- flag ) C-Pass @ 2 = ;
  235: 
  236: : back? ( n -- flag ) 0< ;
  237: : ahead? ( n -- flag ) 0> ;
  238: 
  239: : c-lit
  240:     Display? IF
  241: 	dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
  242:     THEN
  243:     cell+ ;
  244: 
  245: : .name-without ( addr -- addr )
  246: \ prints a name without () e.g. (+LOOP) or (s")
  247:   dup 1 cells - @ look 
  248:   IF   name>string over c@ '( = IF 1 /string THEN
  249:        2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop 
  250:   THEN ;
  251: 
  252: : c-c"
  253: 	Display? IF nl .name-without THEN
  254:         count 2dup + aligned -rot
  255:         Display?
  256:         IF      bl cemit 0 .string
  257:                 [char] " cemit bl cemit
  258:         ELSE    2drop
  259:         THEN ;
  260: 
  261: 
  262: : Forward? ( a-addr true | false -- a-addr true | false )
  263: \ a-addr1 is pointer into branch table
  264: \ returns true when jump is a forward jump
  265:         IF      dup dup @ swap 1 cells - @ -
  266:                 Ahead? IF true ELSE drop false THEN
  267:                 \ only if forward jump
  268:         ELSE    false THEN ;
  269: 
  270: : RepeatCheck ( a-addr1 a-addr2 true | false -- false )
  271:         IF  BEGIN  2dup
  272:                    1 cells - @ swap dup @ +
  273:                    u<=
  274:             WHILE  drop dup cell+
  275:                    MoreBranchAddr? 0=
  276:             UNTIL  false
  277:             ELSE   true
  278:             THEN
  279:         ELSE false
  280:         THEN ;
  281: 
  282: : c-branch
  283:         Scan?
  284:         IF      dup @ Branch!
  285:                 dup @ back?
  286:                 IF                      \ might be: AGAIN, REPEAT
  287:                         dup cell+ BranchAddr? Forward?
  288:                         RepeatCheck
  289:                         IF      RepeatCode Type!
  290:                                 cell+ Disable swap !
  291:                         ELSE    AgainCode Type!
  292:                         THEN
  293:                 ELSE    dup cell+ BranchAddr? Forward?
  294:                         IF      ElseCode Type! drop
  295:                         ELSE    AheadCode Type!
  296:                         THEN
  297:                 THEN
  298:         THEN
  299:         Display?
  300:         IF
  301:                 dup @ back?
  302:                 IF                      \ might be: AGAIN, REPEAT
  303:                         level- nl
  304:                         dup cell+ BranchAddr? Forward?
  305:                         RepeatCheck
  306:                         IF      drop S" REPEAT " .struc nl
  307:                         ELSE    S" AGAIN " .struc nl
  308:                         THEN
  309:                 ELSE    MyBranch cell+ @ LeaveCode =
  310: 			IF 	S" LEAVE " .struc
  311: 			ELSE
  312: 				dup cell+ BranchAddr? Forward?
  313:        	                 	IF      dup cell+ @ WhileCode2 =
  314:        	                         	IF nl S" ELSE" .struc level+
  315:                                 	ELSE level- nl S" ELSE" .struc level+ THEN
  316:                                 	cell+ Disable swap !
  317:                         	ELSE    S" AHEAD" .struc level+
  318:                         	THEN
  319: 			THEN
  320:                 THEN
  321:         THEN
  322:         Debug?
  323:         IF      dup @ +
  324:         ELSE    cell+
  325:         THEN ;
  326: 
  327: : DebugBranch
  328:         Debug?
  329:         IF      dup @ over + swap THEN ; \ return 2 different addresses
  330: 
  331: : c-?branch
  332:         Scan?
  333:         IF      dup @ Branch!
  334:                 dup @ Back?
  335:                 IF      UntilCode Type! THEN
  336:         THEN
  337:         Display?
  338:         IF      dup @ Back?
  339:                 IF      level- nl S" UNTIL " .struc nl
  340:                 ELSE    dup    dup @ over +
  341:                         CheckWhile
  342:                         IF      MyBranch
  343:                                 cell+ dup @ 0=
  344:                                          IF WhileCode2 swap !
  345:                                          ELSE drop THEN
  346:                                 level- nl
  347:                                 S" WHILE " .struc
  348:                                 level+
  349:                         ELSE    MyBranch cell+ @ LeaveCode =
  350: 				IF   s" 0= ?LEAVE " .struc
  351: 				ELSE nl S" IF " .struc level+
  352: 				THEN
  353:                         THEN
  354:                 THEN
  355:         THEN
  356:         DebugBranch
  357:         cell+ ;
  358: 
  359: : c-for
  360:         Display? IF nl S" FOR" .struc level+ THEN ;
  361: 
  362: : c-loop
  363:         Display? IF level- nl .name-without bl cemit nl THEN
  364:         DebugBranch cell+ 
  365: 	Scan? 
  366: 	IF 	dup BranchAddr? 
  367: 		BEGIN   WHILE cell+ LeaveCode swap !
  368: 			dup MoreBranchAddr?
  369: 		REPEAT
  370: 	THEN
  371: 	cell+ ;
  372: 
  373: : c-do
  374:         Display? IF nl .name-without level+ THEN ;
  375: 
  376: : c-?do
  377:         Display? IF nl S" ?DO" .struc level+ THEN
  378:         DebugBranch cell+ ;
  379: 
  380: : c-exit  dup 1 cells -
  381:         CheckEnd
  382:         IF      Display? IF nlflag off S" ;" Com# .string THEN
  383:                 C-Stop on
  384:         ELSE    Display? IF S" EXIT " .struc THEN
  385:         THEN
  386:         Debug? IF drop THEN ;
  387: 
  388: : c-abort"
  389:         count 2dup + aligned -rot
  390:         Display?
  391:         IF      S" ABORT" .struc
  392:                 [char] " cemit bl cemit 0 .string
  393:                 [char] " cemit bl cemit
  394:         ELSE    2drop
  395:         THEN ;
  396: 
  397: [IFDEF] (does>)
  398: : c-does>               \ end of create part
  399:         Display? IF S" DOES> " Com# .string THEN
  400: 	maxaligned /does-handler + ;
  401: [THEN]
  402: 
  403: [IFDEF] (compile)
  404: : c-(compile)
  405:     Display?
  406:     IF
  407: 	s" POSTPONE " Com# .string
  408: 	dup @ look 0= ABORT" SEE: No valid XT"
  409: 	name>string 0 .string bl cemit
  410:     THEN
  411:     cell+ ;
  412: [THEN]
  413: 
  414: CREATE C-Table
  415: 	        ' lit A,            ' c-lit A,
  416: 		' (s") A,	    ' c-c" A,
  417:        		 ' (.") A,	    ' c-c" A,
  418:         	' "lit A,           ' c-c" A,
  419: [IFDEF] (c")	' (c") A,	    ' c-c" A, [THEN]
  420:         	' (do) A,           ' c-do A,
  421: [IFDEF] (+do)	' (+do) A,	    ' c-do A, [THEN]
  422: [IFDEF] (u+do)	' (u+do) A,	    ' c-do A, [THEN]
  423: [IFDEF] (-do)	' (-do) A,	    ' c-do A, [THEN]
  424: [IFDEF] (u-do)	' (u-do) A,	    ' c-do A, [THEN]
  425:         	' (?do) A,          ' c-?do A,
  426:         	' (for) A,          ' c-for A,
  427:         	' ?branch A,        ' c-?branch A,
  428:         	' branch A,         ' c-branch A,
  429:         	' (loop) A,         ' c-loop A,
  430:         	' (+loop) A,        ' c-loop A,
  431: [IFDEF] (s+loop) ' (s+loop) A,       ' c-loop A, [THEN]
  432: [IFDEF] (-loop) ' (-loop) A,        ' c-loop A, [THEN]
  433:         	' (next) A,         ' c-loop A,
  434:         	' ;s A,             ' c-exit A,
  435:         	' (abort") A,       ' c-abort" A,
  436: \ only defined if compiler is loaded
  437: [IFDEF] (compile) ' (compile) A,      ' c-(compile) A, [THEN]
  438: [IFDEF] (does>) ' (does>) A,        ' c-does> A, [THEN]
  439:         	0 ,		here 0 ,
  440: 
  441: avariable c-extender
  442: c-extender !
  443: 
  444: \ DOTABLE                                               15may93jaw
  445: 
  446: : DoTable ( cfa -- flag )
  447:         C-Table
  448:         BEGIN   dup @ dup 0= 
  449: 		IF drop cell+ @ dup 
  450: 		  IF ( next table!) dup @ ELSE 
  451: 			( end!) 2drop false EXIT THEN 
  452: 		THEN
  453: 		\ jump over to extender, if any 26jan97jaw
  454:        		2 pick <>
  455:         WHILE   2 cells +
  456:         REPEAT
  457:         nip cell+ perform
  458:         true
  459: 	;
  460: 
  461: : BranchTo? ( a-addr -- a-addr )
  462:         Display?  IF    dup BranchAddr?
  463:                         IF
  464: 				BEGIN cell+ @ dup 20 u>
  465:                                 IF drop nl S" BEGIN " .struc level+
  466:                                 ELSE
  467:                                   dup Disable <> over LeaveCode <> and
  468:                                   IF   WhileCode2 =
  469:                                        IF nl S" THEN " .struc nl ELSE
  470:                                        level- nl S" THEN " .struc nl THEN
  471:                                   ELSE drop THEN
  472:                                 THEN
  473:                                   dup MoreBranchAddr? 0=
  474:                            UNTIL
  475:                         THEN
  476:                   THEN ;
  477: 
  478: : analyse ( a-addr1 -- a-addr2 )
  479:         Branches @ IF BranchTo? THEN
  480:         dup cell+ swap @
  481:         dup >r DoTable r> swap IF drop EXIT THEN
  482:         Display?
  483:         IF look 0= IF  drop dup 1 cells - @ .  \ ABORT" SEE: Bua!"
  484: 	ELSE
  485: 	    dup cell+ count dup immediate-mask and
  486: 	    IF  bl cemit  ." POSTPONE " THEN
  487: 	    31 and rot wordinfo .string  THEN  bl cemit
  488:         ELSE drop
  489:         THEN ;
  490: 
  491: : c-init
  492:         0 YPos ! 0 XPos !
  493:         0 Level ! nlflag off
  494:         BranchTable BranchPointer !
  495:         c-stop off
  496:         Branches on ;
  497: 
  498: : makepass ( a-addr -- )
  499:     c-stop off
  500:     BEGIN
  501: 	analyse
  502: 	c-stop @
  503:     UNTIL drop ;
  504: 
  505: Defer xt-see-xt ( xt -- )
  506: \ this one is just a forward declaration for indirect recursion
  507: 
  508: : .defname ( xt c-addr u -- )
  509:     rot look
  510:     if ( c-addr u nfa )
  511: 	-rot type space .name
  512:     else
  513: 	drop ." noname " type
  514:     then
  515:     space ;
  516: 
  517: Defer discode ( addr u -- ) \ gforth
  518: \G hook for the disassembler: disassemble code at addr of length u
  519: ' dump IS discode
  520: 
  521: : next-head ( addr1 -- addr2 ) \ gforth
  522:     \G find the next header starting after addr1, up to here (unreliable).
  523:     here swap u+do
  524: 	i head?
  525: 	if
  526: 	    i unloop exit
  527: 	then
  528:     cell +loop
  529:     here ;
  530: 
  531: : umin ( u1 u2 -- u )
  532:     2dup u>
  533:     if
  534: 	swap
  535:     then
  536:     drop ;
  537: 	
  538: : next-prim ( addr1 -- addr2 ) \ gforth
  539:     \G find the next primitive after addr1 (unreliable)
  540:     1+ >r -1 primstart
  541:     begin ( umin head R: boundary )
  542: 	@ dup
  543:     while
  544: 	tuck name>int >code-address ( head1 umin ca R: boundary )
  545: 	r@ - umin
  546: 	swap
  547:     repeat
  548:     drop dup r@ negate u>=
  549:     \ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)"
  550:     if ( umin R: boundary ) \ no primitive found behind -> use a default length
  551: 	drop 31
  552:     then
  553:     r> + ;
  554: 
  555: : seecode ( xt -- )
  556:     dup s" Code" .defname
  557:     threading-method
  558:     if
  559: 	>code-address
  560:     then
  561:     dup in-dictionary? \ user-defined code word?
  562:     if
  563: 	dup next-head
  564:     else
  565: 	dup next-prim
  566:     then
  567:     over - discode
  568:     ." end-code" cr ;
  569: : seevar ( xt -- )
  570:     s" Variable" .defname cr ;
  571: : seeuser ( xt -- )
  572:     s" User" .defname cr ;
  573: : seecon ( xt -- )
  574:     dup >body ?
  575:     s" Constant" .defname cr ;
  576: : seevalue ( xt -- )
  577:     dup >body ?
  578:     s" Value" .defname cr ;
  579: : seedefer ( xt -- )
  580:     dup >body @ xt-see-xt cr
  581:     dup s" Defer" .defname cr
  582:     >name ?dup-if
  583: 	." IS " .name cr
  584:     else
  585: 	." lastxt >body !"
  586:     then ;
  587: : see-threaded ( addr -- )
  588:     C-Pass @ DebugMode = IF
  589: 	ScanMode c-pass !
  590: 	EXIT
  591:     THEN
  592:     ScanMode c-pass ! dup makepass
  593:     DisplayMode c-pass ! makepass ;
  594: : seedoes ( xt -- )
  595:     dup s" create" .defname cr
  596:     S" DOES> " Com# .string XPos @ Level !
  597:     >does-code see-threaded ;
  598: : seecol ( xt -- )
  599:     dup s" :" .defname nl
  600:     2 Level !
  601:     >body see-threaded ;
  602: : seefield ( xt -- )
  603:     dup >body ." 0 " ? ." 0 0 "
  604:     s" Field" .defname cr ;
  605: 
  606: : xt-see ( xt -- ) \ gforth
  607:     \G Decompile the definition represented by @i{xt}.
  608:     cr c-init
  609:     dup >does-code
  610:     if
  611: 	seedoes EXIT
  612:     then
  613:     dup xtprim?
  614:     if
  615: 	seecode EXIT
  616:     then
  617:     dup >code-address
  618:     CASE
  619: 	docon: of seecon endof
  620: 	docol: of seecol endof
  621: 	dovar: of seevar endof
  622: [ [IFDEF] douser: ]
  623: 	douser: of seeuser endof
  624: [ [THEN] ]
  625: [ [IFDEF] dodefer: ]
  626: 	dodefer: of seedefer endof
  627: [ [THEN] ]
  628: [ [IFDEF] dofield: ]
  629: 	dofield: of seefield endof
  630: [ [THEN] ]
  631: 	over       of seecode endof \ direct threaded code words
  632: 	over >body of seecode endof \ indirect threaded code words
  633: 	2drop abort" unknown word type"
  634:     ENDCASE ;
  635: 
  636: : (xt-see-xt) ( xt -- )
  637:     xt-see cr ." lastxt" ;
  638: ' (xt-see-xt) is xt-see-xt
  639: 
  640: : (.immediate) ( xt -- )
  641:     ['] execute = if
  642: 	."  immediate"
  643:     then ;
  644: 
  645: : name-see ( nfa -- )
  646:     dup name>int >r
  647:     dup name>comp 
  648:     over r@ =
  649:     if \ normal or immediate word
  650: 	swap xt-see (.immediate)
  651:     else
  652: 	r@ ['] compile-only-error =
  653: 	if \ compile-only word
  654: 	    swap xt-see (.immediate) ."  compile-only"
  655: 	else \ interpret/compile word
  656: 	    r@ xt-see-xt cr
  657: 	    swap xt-see-xt cr
  658: 	    ." interpret/compile " over .name (.immediate)
  659: 	then
  660:     then
  661:     rdrop drop ;
  662: 
  663: : see ( "<spaces>name" -- ) \ tools
  664:     \G Locate @var{name} using the current search order. Display the
  665:     \G definition of @var{name}. Since this is achieved by decompiling
  666:     \G the definition, the formatting is mechanised and some source
  667:     \G information (comments, interpreted sequences within definitions
  668:     \G etc.) is lost.
  669:     name find-name dup 0=
  670:     IF
  671: 	drop -&13 throw
  672:     THEN
  673:     name-see ;
  674: 
  675: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>