File:  [gforth] / gforth / see.fs
Revision 1.35: download - view: text, annotated - select for diffs
Sat Mar 17 21:36:41 2001 UTC (19 years, 11 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Further peephole optimization preparation in cross.fs:
- compile calls now works
- compile Create/DOES> better prepaired (doesn't work yet)
- compile Create/Variable doesn't work yet
- no peephole optimization yet
See calls works

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

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