File:  [gforth] / gforth / see.fs
Revision 1.15: download - view: text, annotated - select for diffs
Wed Jan 29 21:32:38 1997 UTC (24 years, 7 months ago) by pazsan
Branches: MAIN
CVS tags: v0-3-0, HEAD
Fixes in see
Split kernel conditionals in extra file

    1: \ SEE.FS       highend SEE for ANSforth                16may93jaw
    2: 
    3: \ Copyright (C) 1995 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 termsize.fs
   29: 
   30: decimal
   31: 
   32: \ Screen format words                                   16may93jaw
   33: 
   34: VARIABLE C-Output   1 C-Output  !
   35: VARIABLE C-Formated 1 C-Formated !
   36: VARIABLE C-Highlight 0 C-Highlight !
   37: VARIABLE C-Clearline 0 C-Clearline !
   38: 
   39: VARIABLE XPos
   40: VARIABLE YPos
   41: VARIABLE Level
   42: 
   43: : Format        C-Formated @ C-Output @ and
   44:                 IF dup spaces XPos +! ELSE drop THEN ;
   45: 
   46: : level+        7 Level +!
   47:                 Level @ XPos @ -
   48:                 dup 0> IF Format ELSE drop THEN ;
   49: 
   50: : level-        -7 Level +! ;
   51: 
   52: VARIABLE nlflag
   53: VARIABLE uppercase	\ structure words are in uppercase
   54: 
   55: DEFER nlcount ' noop IS nlcount
   56: 
   57: : nl            nlflag on ;
   58: : (nl)          nlcount
   59:                 XPos @ Level @ = ?Exit
   60:                 C-Formated @ IF
   61:                 C-Output @
   62:                 IF C-Clearline @ IF cols XPos @ - spaces
   63:                                  ELSE cr THEN
   64:                 1 YPos +! 0 XPos !
   65:                 Level @ spaces
   66:                 THEN Level @ XPos ! THEN ;
   67: 
   68: : warp?         ( len -- len )
   69:                 nlflag @ IF (nl) nlflag off THEN
   70:                 XPos @ over + cols u>= IF (nl) THEN ;
   71: 
   72: : c-to-upper
   73:   dup [char] a >= over [char] z <= and if  bl -  then ;
   74: 
   75: : ctype         ( adr len -- )
   76:                 warp? dup XPos +! C-Output @ 
   77: 		IF uppercase @ IF bounds ?DO i c@ c-to-upper emit LOOP
   78: 				  uppercase off ELSE type THEN
   79: 		ELSE 2drop THEN ;
   80: 
   81: : cemit         1 warp?
   82:                 over bl = Level @ XPos @ = and
   83:                 IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN
   84:                 THEN ;
   85: 
   86: DEFER .string
   87: 
   88: [IFDEF] Green
   89: VARIABLE Colors Colors on
   90: 
   91: : (.string)     ( c-addr u n -- )
   92:                 over warp? drop
   93:                 Colors @
   94:                 IF C-Highlight @ ?dup
   95:                    IF   CT@ swap CT@ or
   96:                    ELSE CT@
   97:                    THEN
   98:                 attr! ELSE drop THEN
   99:                 ctype  ct @ attr! ;
  100: [ELSE]
  101: : (.string)     ( c-addr u n -- )
  102:                 drop ctype ;
  103: [THEN]
  104: 
  105: ' (.string) IS .string
  106: 
  107: 
  108: : .struc        
  109: 	uppercase on Str# .string ;
  110: 
  111: \ CODES                                                 15may93jaw
  112: 
  113: 21 CONSTANT RepeatCode
  114: 22 CONSTANT AgainCode
  115: 23 CONSTANT UntilCode
  116: \ 09 CONSTANT WhileCode
  117: 10 CONSTANT ElseCode
  118: 11 CONSTANT AheadCode
  119: 13 CONSTANT WhileCode2
  120: 14 CONSTANT Disable
  121: 
  122: \ FORMAT WORDS                                          13jun93jaw
  123: 
  124: VARIABLE C-Stop
  125: VARIABLE Branches
  126: 
  127: VARIABLE BranchPointer
  128: VARIABLE SearchPointer
  129: CREATE BranchTable 500 allot
  130: here 3 cells -
  131: ACONSTANT MaxTable
  132: 
  133: : FirstBranch BranchTable cell+ SearchPointer ! ;
  134: 
  135: : (BranchAddr?) ( a-addr -- a-addr true | false )
  136:         SearchPointer @
  137:         BEGIN   dup BranchPointer @ u<
  138:         WHILE
  139:                 dup @ 2 pick <>
  140:         WHILE   3 cells +
  141:         REPEAT
  142:         nip dup  3 cells + SearchPointer ! true
  143:         ELSE
  144:         2drop false
  145:         THEN ;
  146: 
  147: : BranchAddr?
  148:         FirstBranch (BranchAddr?) ;
  149: 
  150: ' (BranchAddr?) ALIAS MoreBranchAddr?
  151: 
  152: : CheckEnd ( a-addr -- true | false )
  153:         BranchTable cell+
  154:         BEGIN   dup BranchPointer @ u<
  155:         WHILE
  156:                 dup @ 2 pick u<=
  157:         WHILE   3 cells +
  158:         REPEAT
  159:         2drop false
  160:         ELSE
  161:         2drop true
  162:         THEN ;
  163: 
  164: \
  165: \                 addrw               addrt
  166: \       BEGIN ... WHILE ... AGAIN ... THEN
  167: \         ^         !        !          ^
  168: \         ----------+--------+          !
  169: \                   !                   !
  170: \                   +-------------------+
  171: \
  172: \
  173: 
  174: : CheckWhile ( a-addrw a-addrt -- true | false )
  175:         BranchTable
  176:         BEGIN   dup BranchPointer @ u<
  177:         WHILE   dup @ 3 pick u>
  178:                 over @ 3 pick u< and
  179:                 IF dup cell+ @ 3 pick u<
  180:                         IF 2drop drop true EXIT THEN
  181:                 THEN
  182:                 3 cells +
  183:         REPEAT
  184:         2drop drop false ;
  185: 
  186: : ,Branch ( a-addr -- )
  187:         BranchPointer @ dup MaxTable u> ABORT" SEE: Table overflow"
  188:         !
  189:         1 cells BranchPointer +! ;
  190: 
  191: : Type!   ( u -- )
  192:         BranchPointer @ 1 cells - ! ;
  193: 
  194: : Branch! ( a-addr rel -- a-addr )
  195:         over + over ,Branch ,Branch 0 ,Branch ;
  196: 
  197: \ DEFER CheckUntil
  198: VARIABLE NoOutput
  199: VARIABLE C-Pass
  200: 
  201: 0 CONSTANT ScanMode
  202: 1 CONSTANT DisplayMode
  203: 2 CONSTANT DebugMode
  204: 
  205: : Scan? ( -- flag ) C-Pass @ 0= ;
  206: : Display? ( -- flag ) C-Pass @ 1 = ;
  207: : Debug? ( -- flag ) C-Pass @ 2 = ;
  208: 
  209: : back? ( n -- flag ) 0< ;
  210: : ahead? ( n -- flag ) 0> ;
  211: 
  212: : c-(compile)
  213:     Display?
  214:     IF
  215: 	s" POSTPONE " Com# .string
  216: 	dup @ look 0= ABORT" SEE: No valid XT"
  217: 	name>string 0 .string bl cemit
  218:     THEN
  219:     cell+ ;
  220: 
  221: : c-lit
  222:     Display? IF
  223: 	dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
  224:     THEN
  225:     cell+ ;
  226: 
  227: : c-s"
  228:         count 2dup + aligned -rot
  229:         Display?
  230:         IF      [char] S cemit [char] " cemit bl cemit 0 .string
  231:                 [char] " cemit bl cemit
  232:         ELSE    2drop
  233:         THEN ;
  234: 
  235: : c-."
  236:         count 2dup + aligned -rot
  237:         Display?
  238:         IF      [char] . cemit
  239:                 [char] " cemit bl cemit 0 .string
  240:                 [char] " cemit bl cemit
  241:         ELSE    2drop
  242:         THEN ;
  243: 
  244: : c-c"
  245:         count 2dup + aligned -rot
  246:         Display?
  247:         IF      [char] C cemit [char] " cemit bl cemit 0 .string
  248:                 [char] " cemit bl cemit
  249:         ELSE    2drop
  250:         THEN ;
  251: 
  252: 
  253: : Forward? ( a-addr true | false -- )
  254:         IF      dup dup @ swap 1 cells - @ -
  255:                 Ahead? IF true ELSE drop false THEN
  256:                 \ only if forward jump
  257:         ELSE    false THEN ;
  258: 
  259: : RepeatCheck
  260:         IF  BEGIN  2dup
  261:                    1 cells - @ swap dup @ +
  262:                    u<=
  263:             WHILE  drop dup cell+
  264:                    MoreBranchAddr? 0=
  265:             UNTIL  false
  266:             ELSE   true
  267:             THEN
  268:         ELSE false
  269:         THEN ;
  270: 
  271: : c-branch
  272:         Scan?
  273:         IF      dup @ Branch!
  274:                 dup @ back?
  275:                 IF                      \ might be: AGAIN, REPEAT
  276:                         dup cell+ BranchAddr? Forward?
  277:                         RepeatCheck
  278:                         IF      RepeatCode Type!
  279:                                 cell+ Disable swap !
  280:                         ELSE    AgainCode Type!
  281:                         THEN
  282:                 ELSE    dup cell+ BranchAddr? Forward?
  283:                         IF      ElseCode Type! drop
  284:                         ELSE    AheadCode Type!
  285:                         THEN
  286:                 THEN
  287:         THEN
  288:         Display?
  289:         IF
  290:                 dup @ back?
  291:                 IF                      \ might be: AGAIN, REPEAT
  292:                         level- nl
  293:                         dup cell+ BranchAddr? Forward?
  294:                         RepeatCheck
  295:                         IF      drop S" REPEAT " .struc nl
  296:                         ELSE    S" AGAIN " .struc nl
  297:                         THEN
  298:                 ELSE    dup cell+ BranchAddr? Forward?
  299:                         IF      dup cell+ @ WhileCode2 =
  300:                                 IF nl S" ELSE" .struc level+
  301:                                 ELSE level- nl S" ELSE" .struc level+ THEN
  302:                                 cell+ Disable swap !
  303:                         ELSE    S" AHEAD" .struc level+
  304:                         THEN
  305:                 THEN
  306:         THEN
  307:         Debug?
  308:         IF      dup @ +
  309:         ELSE    cell+
  310:         THEN ;
  311: 
  312: : MyBranch      ( a-addr -- a-addr a-addr2 )
  313:                 dup @ over +
  314:                 BranchAddr?
  315:                 BEGIN
  316:                 WHILE 1 cells - @
  317:                       over <>
  318:                 WHILE dup @ over +
  319:                       MoreBranchAddr?
  320:                 REPEAT
  321:                 SearchPointer @ 3 cells -
  322:                 ELSE    true ABORT" SEE: Table failure"
  323:                 THEN ;
  324: 
  325: : DebugBranch
  326:         Debug?
  327:         IF      dup @ over + swap THEN ; \ return 2 different addresses
  328: 
  329: : c-?branch
  330:         Scan?
  331:         IF      dup @ Branch!
  332:                 dup @ Back?
  333:                 IF      UntilCode Type! THEN
  334:         THEN
  335:         Display?
  336:         IF      dup @ Back?
  337:                 IF      level- nl S" UNTIL " .struc nl
  338:                 ELSE    dup    dup @ over +
  339:                         CheckWhile
  340:                         IF      MyBranch
  341:                                 cell+ dup @ 0=
  342:                                          IF WhileCode2 swap !
  343:                                          ELSE drop THEN
  344:                                 level- nl
  345:                                 S" WHILE " .struc
  346:                                 level+
  347:                         ELSE    nl S" IF " .struc level+
  348:                         THEN
  349:                 THEN
  350:         THEN
  351:         DebugBranch
  352:         cell+ ;
  353: 
  354: : c-for
  355:         Display? IF nl S" FOR" .struc level+ THEN ;
  356: 
  357: : .name-without
  358: 	dup 1 cells - @ look IF name>string 1 /string 1- .struc ELSE drop THEN ;
  359: 
  360: : c-loop
  361:         Display? IF level- nl .name-without bl cemit nl THEN
  362:         DebugBranch cell+ cell+ ;
  363: 
  364: : c-do
  365:         Display? IF nl .name-without level+ THEN ;
  366: 
  367: : c-?do
  368:         Display? IF nl S" ?DO" .struc level+ THEN
  369:         DebugBranch cell+ ;
  370: 
  371: : c-leave
  372:         Display? IF S" LEAVE " .struc THEN
  373:         Debug? IF dup @ + THEN cell+ ;
  374: 
  375: : c-?leave
  376:         Display? IF S" ?LEAVE " .struc THEN
  377:         cell+ DebugBranch swap cell+ swap cell+ ;
  378: 
  379: : c-exit  dup 1 cells -
  380:         CheckEnd
  381:         IF      Display? IF nlflag off S" ;" Com# .string THEN
  382:                 C-Stop on
  383:         ELSE    Display? IF S" EXIT " .struc THEN
  384:         THEN
  385:         Debug? IF drop THEN ;
  386: 
  387: : c-does>               \ end of create part
  388:         Display? IF S" DOES> " Com# .string THEN
  389:         Cell+ cell+ ;
  390: 
  391: : c-abort"
  392:         count 2dup + aligned -rot
  393:         Display?
  394:         IF      S" ABORT" .struc
  395:                 [char] " cemit bl cemit 0 .string
  396:                 [char] " cemit bl cemit
  397:         ELSE    2drop
  398:         THEN ;
  399: 
  400: 
  401: CREATE C-Table
  402:         ' lit A,            ' c-lit A,
  403: 	' (s") A,	    ' c-s" A,
  404:         ' (.") A,	    ' c-." A,
  405:         ' "lit A,           ' c-c" A,
  406:         comp' leave drop A, ' c-leave A,
  407:         comp' ?leave drop A, ' c-?leave A,
  408:         ' (do) A,           ' c-do A,
  409: 	' (+do) A,	    ' c-do A,
  410: 	' (u+do) A,	    ' c-do A,
  411: 	' (-do) A,	    ' c-do A,
  412: 	' (u-do) A,	    ' c-do A,
  413:         ' (?do) A,          ' c-?do A,
  414:         ' (for) A,          ' c-for A,
  415:         ' ?branch A,        ' c-?branch A,
  416:         ' branch A,         ' c-branch A,
  417:         ' (loop) A,         ' c-loop A,
  418:         ' (+loop) A,        ' c-loop A,
  419:         ' (s+loop) A,       ' c-loop A,
  420:         ' (-loop) A,        ' c-loop A,
  421:         ' (next) A,         ' c-loop A,
  422:         ' ;s A,             ' c-exit A,
  423:         ' (does>) A,        ' c-does> A,
  424:         ' (abort") A,       ' c-abort" A,
  425:         ' (compile) A,      ' c-(compile) A,
  426:         0 ,		here 0 ,
  427: 
  428: avariable c-extender
  429: c-extender !
  430: 
  431: \ DOTABLE                                               15may93jaw
  432: 
  433: : DoTable ( cfa -- flag )
  434:         C-Table
  435:         BEGIN   dup @ dup 0= 
  436: 		IF drop cell+ @ dup 
  437: 		  IF ( next table!) dup @ ELSE 
  438: 			( end!) 2drop false EXIT THEN 
  439: 		THEN
  440: 		\ jump over to extender, if any 26jan97jaw
  441:        		2 pick <>
  442:         WHILE   2 cells +
  443:         REPEAT
  444:         nip cell+ perform
  445:         true
  446: 	;
  447: 
  448: : BranchTo? ( a-addr -- a-addr )
  449:         Display?  IF     dup BranchAddr?
  450:                         IF
  451: 				BEGIN cell+ @ dup 20 u>
  452:                                 IF drop nl S" BEGIN " .struc level+
  453:                                 ELSE
  454:                                   dup Disable <>
  455:                                   IF   WhileCode2 =
  456:                                        IF nl S" THEN " .struc nl ELSE
  457:                                        level- nl S" THEN " .struc nl THEN
  458:                                   ELSE drop THEN
  459:                                 THEN
  460:                                   dup MoreBranchAddr? 0=
  461:                            UNTIL
  462:                         THEN
  463:                   THEN ;
  464: 
  465: : analyse ( a-addr1 -- a-addr2 )
  466:         Branches @ IF BranchTo? THEN
  467:         dup cell+ swap @
  468:         dup >r DoTable r> swap IF drop EXIT THEN
  469:         Display?
  470:         IF look 0= IF  drop dup 1 cells - @ .  \ ABORT" SEE: Bua!"
  471:            ELSE  dup cell+ count 31 and rot wordinfo .string  THEN  bl cemit
  472:         ELSE drop
  473:         THEN ;
  474: 
  475: : c-init
  476:         0 YPos ! 0 XPos !
  477:         0 Level ! nlflag off
  478:         BranchTable BranchPointer !
  479:         c-stop off
  480:         Branches on ;
  481: 
  482: : makepass ( a-addr -- )
  483:     c-stop off
  484:     BEGIN
  485: 	analyse
  486: 	c-stop @
  487:     UNTIL drop ;
  488: 
  489: Defer xt-see-xt ( xt -- )
  490: \ this one is just a forward declaration for indirect recursion
  491: 
  492: : .defname ( xt c-addr u -- )
  493:     rot look
  494:     if ( c-addr u nfa )
  495: 	-rot type space .name
  496:     else
  497: 	drop ." noname " type
  498:     then
  499:     space ;
  500: 
  501: Defer discode ( addr -- )
  502: \  hook for the disassembler: disassemble code at addr (as far as the
  503: \  disassembler thinks is sensible)
  504: :noname ( addr -- )
  505:     drop ." ..." ;
  506: IS discode
  507: 
  508: : seecode ( xt -- )
  509:     dup s" Code" .defname
  510:     >body discode
  511:     ."  end-code" cr ;
  512: : seevar ( xt -- )
  513:     s" Variable" .defname cr ;
  514: : seeuser ( xt -- )
  515:     s" User" .defname cr ;
  516: : seecon ( xt -- )
  517:     dup >body ?
  518:     s" Constant" .defname cr ;
  519: : seevalue ( xt -- )
  520:     dup >body ?
  521:     s" Value" .defname cr ;
  522: : seedefer ( xt -- )
  523:     dup >body @ xt-see-xt cr
  524:     dup s" Defer" .defname cr
  525:     >name dup ??? = if
  526: 	drop ." lastxt >body !"
  527:     else
  528: 	." IS " .name cr
  529:     then ;
  530: : see-threaded ( addr -- )
  531:     C-Pass @ DebugMode = IF
  532: 	ScanMode c-pass !
  533: 	EXIT
  534:     THEN
  535:     ScanMode c-pass ! dup makepass
  536:     DisplayMode c-pass ! makepass ;
  537: : seedoes ( xt -- )
  538:     dup s" create" .defname cr
  539:     S" DOES> " Com# .string XPos @ Level !
  540:     >does-code see-threaded ;
  541: : seecol ( xt -- )
  542:     dup s" :" .defname nl
  543:     2 Level !
  544:     >body see-threaded ;
  545: : seefield ( xt -- )
  546:     dup >body ." 0 " ? ." 0 0 "
  547:     s" Field" .defname cr ;
  548: 
  549: : xt-see ( xt -- )
  550:     cr c-init
  551:     dup >does-code
  552:     if
  553: 	seedoes EXIT
  554:     then
  555:     dup forthstart u<
  556:     if
  557: 	seecode EXIT
  558:     then
  559:     dup >code-address
  560:     CASE
  561: 	docon: of seecon endof
  562: 	docol: of seecol endof
  563: 	dovar: of seevar endof
  564: 	douser: of seeuser endof
  565: 	dodefer: of seedefer endof
  566: 	dofield: of seefield endof
  567: 	over >body of seecode endof
  568: 	2drop abort" unknown word type"
  569:     ENDCASE ;
  570: 
  571: : (xt-see-xt) ( xt -- )
  572:     xt-see cr ." lastxt" ;
  573: ' (xt-see-xt) is xt-see-xt
  574: 
  575: : (.immediate) ( xt -- )
  576:     ['] execute = if
  577: 	."  immediate"
  578:     then ;
  579: 
  580: : name-see ( nfa -- )
  581:     dup name>int >r
  582:     dup name>comp 
  583:     over r@ =
  584:     if \ normal or immediate word
  585: 	swap xt-see (.immediate)
  586:     else
  587: 	r@ ['] compile-only-error =
  588: 	if \ compile-only word
  589: 	    swap xt-see (.immediate) ."  compile-only"
  590: 	else \ interpret/compile word
  591: 	    r@ xt-see-xt cr
  592: 	    swap xt-see-xt cr
  593: 	    ." interpret/compile " over .name (.immediate)
  594: 	then
  595:     then
  596:     rdrop drop ;
  597: 
  598: : see ( "name" -- ) \ tools
  599:     name find-name dup 0=
  600:     IF
  601: 	drop -&13 bounce
  602:     THEN
  603:     name-see ;
  604: 
  605: 

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