File:  [gforth] / gforth / see.fs
Revision 1.4: download - view: text, annotated - select for diffs
Mon Sep 12 19:00:37 1994 UTC (29 years, 6 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added forth variants for primitives
Added a generator for forth primitives
Cleaned up some minor errors
Changed names of local access (was cell size dependent)
Where is "getopt.h"???!? Added tiny workaround. Where is getopt_long?

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

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