File:  [gforth] / gforth / see.fs
Revision 1.9: download - view: text, annotated - select for diffs
Tue Nov 7 18:06:59 1995 UTC (25 years, 5 months ago) by anton
Branches: MAIN
CVS tags: gforth-0_1beta, HEAD
added copyright headers
changes to loadfilename & co. to make savesystem transparent to
 assertions and ~~

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

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