File:  [gforth] / gforth / see.fs
Revision 1.8: download - view: text, annotated - select for diffs
Thu Nov 2 14:20:53 1995 UTC (25 years, 5 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Some bugfixes and added features (like -loop) in see.fs and debug.fs
Defined LONG_LATENCY in hppa.h (gives more than 10% speed boost)

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

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