File:  [gforth] / gforth / see.fs
Revision 1.13: download - view: text, annotated - select for diffs
Wed Aug 21 14:58:44 1996 UTC (24 years, 6 months ago) by anton
Branches: MAIN
CVS tags: HEAD
a little cleanup in 386.h
renamed special: to interpret/compile:
renamed save-string to save-mem
added extend-mem
replaced (name>) with ((name>))
replaced name> with name>int and name>comp
renamed compile-only to compile-only-error
replaced xt>i with name>int
replaced xt>c with name>comp
removed xt>s
removed found
search-wordlist now delivers interpretation-xt
replaced (sfind) with find-name
replaced C' with COMP' and [C'] with [COMP']
removed S' and [S']
added hex.
added some helper words
adapted other words to the changes
started documenting the intergration of Gforth in applications

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

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