File:  [gforth] / gforth / see.fs
Revision 1.7: download - view: text, annotated - select for diffs
Sat Oct 7 17:38:19 1995 UTC (25 years, 6 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added code.fs (code, ;code, end-code, assembler)
renamed dostruc to dofield
made index and doc-entries nicer
Only words containing 'e' or 'E' are converted to FP numbers.
added many wordset comments
added flush-icache primitive and FLUSH_ICACHE macro
added +DO, U+DO, -DO, U-DO and -LOOP
added code address labels (`docol:' etc.)
fixed sparc cache_flush

    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 dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit THEN
  192:         cell+ ;
  193: 
  194: : c-flit
  195:         Display? IF  dup f@ scratch represent 0=
  196:                      IF    2drop  scratch 3 min 0 .string
  197:                      ELSE   IF  '- cemit  THEN  1-
  198:                             scratch over c@ cemit '. cemit 1 /string 0 .string
  199:                             'E cemit
  200:                             dup abs 0 <# #S rot sign #> 0 .string bl cemit
  201:                  THEN THEN
  202:         float+ ;
  203: 
  204: : c-s"
  205:         count 2dup + aligned -rot
  206:         Display?
  207:         IF      [char] S cemit [char] " cemit bl cemit 0 .string
  208:                 [char] " cemit bl cemit
  209:         ELSE    2drop
  210:         THEN ;
  211: 
  212: : c-."
  213:         count 2dup + aligned -rot
  214:         Display?
  215:         IF      [char] . cemit
  216:                 [char] " cemit bl cemit 0 .string
  217:                 [char] " cemit bl cemit
  218:         ELSE    2drop
  219:         THEN ;
  220: 
  221: : c-c"
  222:         count 2dup + aligned -rot
  223:         Display?
  224:         IF      [char] C cemit [char] " cemit bl cemit 0 .string
  225:                 [char] " cemit bl cemit
  226:         ELSE    2drop
  227:         THEN ;
  228: 
  229: 
  230: : Forward? ( a-addr true | false -- )
  231:         IF      dup dup @ swap 1 cells - @ -
  232:                 Ahead? IF true ELSE drop false THEN
  233:                 \ only if forward jump
  234:         ELSE    false THEN ;
  235: 
  236: : RepeatCheck
  237:         IF  BEGIN  2dup
  238:                    1 cells - @ swap dup @ +
  239:                    u<=
  240:             WHILE  drop dup cell+
  241:                    MoreBranchAddr? 0=
  242:             UNTIL  false
  243:             ELSE   true
  244:             THEN
  245:         ELSE false
  246:         THEN ;
  247: 
  248: : c-branch
  249:         Scan?
  250:         IF      dup @ Branch!
  251:                 dup @ back?
  252:                 IF                      \ might be: AGAIN, REPEAT
  253:                         dup cell+ BranchAddr? Forward?
  254:                         RepeatCheck
  255:                         IF      RepeatCode Type!
  256:                                 cell+ Disable swap !
  257:                         ELSE    AgainCode Type!
  258:                         THEN
  259:                 ELSE    dup cell+ BranchAddr? Forward?
  260:                         IF      ElseCode Type! drop
  261:                         ELSE    AheadCode Type!
  262:                         THEN
  263:                 THEN
  264:         THEN
  265:         Display?
  266:         IF
  267:                 dup @ back?
  268:                 IF                      \ might be: AGAIN, REPEAT
  269:                         level- nl
  270:                         dup cell+ BranchAddr? Forward?
  271:                         RepeatCheck
  272:                         IF      drop S" REPEAT " .struc nl
  273:                         ELSE    S" AGAIN " .struc nl
  274:                         THEN
  275:                 ELSE    dup cell+ BranchAddr? Forward?
  276:                         IF      dup cell+ @ WhileCode2 =
  277:                                 IF nl S" ELSE" .struc level+
  278:                                 ELSE level- nl S" ELSE" .struc level+ THEN
  279:                                 cell+ Disable swap !
  280:                         ELSE    S" AHEAD" .struc level+
  281:                         THEN
  282:                 THEN
  283:         THEN
  284:         Debug?
  285:         IF      dup @ +
  286:         ELSE    cell+
  287:         THEN ;
  288: 
  289: : MyBranch      ( a-addr -- a-addr a-addr2 )
  290:                 dup @ over +
  291:                 BranchAddr?
  292:                 BEGIN
  293:                 WHILE 1 cells - @
  294:                       over <>
  295:                 WHILE dup @ over +
  296:                       MoreBranchAddr?
  297:                 REPEAT
  298:                 SearchPointer @ 3 cells -
  299:                 ELSE    true ABORT" SEE: Table failure"
  300:                 THEN ;
  301: 
  302: : DebugBranch
  303:         Debug?
  304:         IF      dup @ over + swap THEN ; \ return 2 different addresses
  305: 
  306: : c-?branch
  307:         Scan?
  308:         IF      dup @ Branch!
  309:                 dup @ Back?
  310:                 IF      UntilCode Type! THEN
  311:         THEN
  312:         Display?
  313:         IF      dup @ Back?
  314:                 IF      level- nl S" UNTIL " .struc nl
  315:                 ELSE    dup    dup @ over +
  316:                         CheckWhile
  317:                         IF      MyBranch
  318:                                 cell+ dup @ 0=
  319:                                          IF WhileCode2 swap !
  320:                                          ELSE drop THEN
  321:                                 level- nl
  322:                                 S" WHILE" .struc
  323:                                 level+
  324:                         ELSE    nl S" IF" .struc level+
  325:                         THEN
  326:                 THEN
  327:         THEN
  328:         DebugBranch
  329:         cell+ ;
  330: 
  331: : c-do
  332:         Display? IF nl S" DO" .struc level+ THEN ;
  333: 
  334: : c-?do
  335:         Display? IF nl S" ?DO" .struc level+ THEN
  336:         DebugBranch cell+ ;
  337: 
  338: : c-for
  339:         Display? IF nl S" FOR" .struc level+ THEN ;
  340: 
  341: : c-next
  342:         Display? IF level- nl S" NEXT " .struc nl THEN
  343:         DebugBranch cell+ cell+ ;
  344: 
  345: : c-loop
  346:         Display? IF level- nl S" LOOP " .struc nl THEN
  347:         DebugBranch cell+ cell+ ;
  348: 
  349: 
  350: : c-+loop
  351:         Display? IF level- nl S" +LOOP " .struc nl THEN
  352:         DebugBranch cell+ cell+ ;
  353: 
  354: : c-leave
  355:         Display? IF S" LEAVE " .struc THEN
  356:         Debug? IF dup @ + THEN cell+ ;
  357: 
  358: : c-?leave
  359:         Display? IF S" ?LEAVE " .struc THEN
  360:         cell+ DebugBranch swap cell+ swap cell+ ;
  361: 
  362: : c-exit  dup 1 cells -
  363:         CheckEnd
  364:         IF      Display? IF nlflag off S" ;" Com# .string THEN
  365:                 C-Stop on
  366:         ELSE    Display? IF S" EXIT " .struc THEN
  367:         THEN
  368:         Debug? IF drop THEN ;
  369: 
  370: : c-does>               \ end of create part
  371:         Display? IF S" DOES> " Com# .string THEN
  372:         Cell+ cell+ ;
  373: 
  374: : c-abort"
  375:         count 2dup + aligned -rot
  376:         Display?
  377:         IF      S" ABORT" .struc
  378:                 [char] " cemit bl cemit 0 .string
  379:                 [char] " cemit bl cemit
  380:         ELSE    2drop
  381:         THEN ;
  382: 
  383: 
  384: CREATE C-Table
  385:         ' lit A,         ' c-lit A,
  386:         ' flit A,        ' c-flit A,
  387:         ' (s") A,        ' c-s" A,
  388:         ' (.") A,        ' c-." A,
  389:         ' "lit A,        ' c-c" A,
  390:         ' ?branch A,     ' c-?branch A,
  391:         ' branch A,      ' c-branch A,
  392:         ' leave A,       ' c-leave A,
  393:         ' ?leave A,      ' c-?leave A,
  394:         ' (do) A,        ' c-do A,
  395:         ' (?do) A,       ' c-?do A,
  396:         ' (for) A,       ' c-for A,
  397:         ' (loop) A,      ' c-loop A,
  398:         ' (+loop) A,     ' c-+loop A,
  399:         ' (next) A,      ' c-next A,
  400:         ' ;s A,          ' c-exit A,
  401:         ' (does>) A,     ' c-does> A,
  402:         ' (abort") A,    ' c-abort" A,
  403:         ' (compile) A,   ' c-(compile) A,
  404:         0 ,
  405: 
  406: \ DOTABLE                                               15may93jaw
  407: 
  408: : DoTable ( cfa -- flag )
  409:         C-Table
  410:         BEGIN   dup @ dup
  411:         WHILE   2 pick <>
  412:         WHILE   2 cells +
  413:         REPEAT
  414:         nip cell+ @ EXECUTE
  415:         true
  416:         ELSE
  417:         2drop drop false
  418:         THEN ;
  419: 
  420: : BranchTo? ( a-addr -- a-addr )
  421:         Display?  IF     dup BranchAddr?
  422:                         IF BEGIN cell+ @ dup 20 u>
  423:                                 IF drop nl S" BEGIN " .struc level+
  424:                                 ELSE
  425:                                   dup Disable <>
  426:                                   IF   WhileCode2 =
  427:                                        IF nl S" THEN " .struc nl ELSE
  428:                                        level- nl S" THEN " .struc nl THEN
  429:                                   ELSE drop THEN
  430:                                 THEN
  431:                                   dup MoreBranchAddr? 0=
  432:                            UNTIL
  433:                         THEN
  434:                   THEN ;
  435: 
  436: : analyse ( a-addr1 -- a-addr2 )
  437:         Branches @ IF BranchTo? THEN
  438:         dup cell+ swap @
  439:         dup >r DoTable r> swap IF drop EXIT THEN
  440:         Display?
  441:         IF look 0= IF  drop dup 1 cells - @ .  \ ABORT" SEE: Bua!"
  442:            ELSE  dup cell+ count 31 and rot wordinfo .string  THEN  bl cemit
  443:         ELSE drop
  444:         THEN ;
  445: 
  446: : c-init
  447:         0 YPos ! 0 XPos !
  448:         0 Level ! nlflag off
  449:         BranchTable BranchPointer !
  450:         c-stop off
  451:         Branches on ;
  452: 
  453: : makepass ( a-addr -- )
  454:         c-stop off
  455:         BEGIN
  456:                 analyse
  457:                 c-stop @
  458:         UNTIL drop ;
  459: 
  460: DEFER dosee
  461: 
  462: : dopri .name ." is primitive" cr ;
  463: : dovar ." Variable " .name cr ;
  464: : douse ." User " .name cr ;
  465: : docon  dup cell+ (name>) >body @ . ." Constant " .name cr ;
  466: : doval  dup cell+ (name>) >body @ . ." Value " .name cr ;
  467: : dodef ." Defer " dup >r .name cr
  468:          here @ look 0= ABORT" SEE: No valid xt in defered word"
  469: 	 here @ look drop dosee cr
  470:         ." ' " .name r> ." IS " .name cr ;
  471: : dodoe ." Create " dup .name cr
  472:         S" DOES> " Com# .string XPos @ Level ! name>
  473:         >does-code dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
  474:         ScanMode c-pass ! dup makepass
  475:         DisplayMode c-pass ! makepass ;
  476: : doali here @ .name ." Alias " .name cr
  477:         here @ dosee ;
  478: : docol S" : " Com# .string
  479:         dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit
  480:         ( XPos @ ) 2 Level !
  481:         name> >body
  482:         C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
  483:         ScanMode c-pass ! dup makepass
  484:         DisplayMode c-pass ! makepass ;
  485: 
  486: create wordtypes
  487:         Pri# ,   ' dopri A,
  488:         Var# ,   ' dovar A,
  489:         Con# ,   ' docon A,
  490:         Val# ,   ' doval A,
  491:         Def# ,   ' dodef A,
  492:         Doe# ,   ' dodoe A,
  493:         Ali# ,   ' doali A,
  494:         Col# ,   ' docol A,
  495: 	Use# ,   ' douse A,
  496:         0 ,
  497: 
  498: : (dosee) ( lfa -- )
  499:         dup dup cell+ c@ >r
  500:         wordinfo
  501:         wordtypes
  502:         BEGIN dup @ dup
  503:         WHILE 2 pick = IF cell+ @ nip EXECUTE
  504: 	                  r> dup 32 and IF ."  immediate" THEN
  505: 			         64 and IF ."  restrict" THEN EXIT THEN
  506:               2 cells +
  507:         REPEAT
  508:         2drop rdrop
  509:         .name ." Don't know how to handle" cr ;
  510: 
  511: ' (dosee) IS dosee
  512: 
  513: : xtc ( xt -- )       \ do see at xt
  514:         Look 0= ABORT" SEE: No valid XT"
  515:         cr c-init
  516:         dosee ;
  517: 
  518: : see   name sfind 0= IF ." Word unknown" cr exit THEN
  519:         xtc ;
  520: 
  521: : lfc   cr c-init cell+ dosee ;
  522: : nfc   cr c-init dosee ;
  523: 
  524: 

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