File:  [gforth] / gforth / see.fs
Revision 1.3: download - view: text, annotated - select for diffs
Wed Jul 13 19:21:08 1994 UTC (26 years, 7 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Moved setjmp from engine to go_forth, because the socalled "globbered"
variables where saved in memory (and this slows down everything).
Added global up0 for security (up is globbered).

Added restrict's functionalitz to cross.fs

removed all occurency of cell+ name>, because the bug in name> is
fixed.

Added a dusty workaround at the end of prims2x.fs, because of
strange exceptions.

    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 .name ." is variable" cr ;
  453: : docon  dup .name ." is constant, value: "
  454:          cell+ (name>) >body @ . cr ;
  455: : doval .name ." is value" cr ;
  456: : dodef .name ." is defered word, is: "
  457:          here @ look 0= ABORT" SEE: No valid xt in defered word"
  458:         .name cr here @ look drop dosee ;
  459: : dodoe .name ." is created word" cr
  460:         S" DOES> " Com# .string XPos @ Level !
  461:         here @ dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
  462:         ScanMode c-pass ! dup makepass
  463:         DisplayMode c-pass ! makepass ;
  464: : doali .name ." is alias of "
  465:         here @ .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:         0 ,
  485: 
  486: : (dosee) ( lfa -- )
  487:         dup dup cell+ c@ 32 and IF over .name ." is an immediate word" cr THEN
  488:         wordinfo
  489:         wordtypes
  490:         BEGIN dup @ dup
  491:         WHILE 2 pick = IF cell+ @ nip EXECUTE EXIT THEN
  492:               2 cells +
  493:         REPEAT
  494:         2drop
  495:         .name ." Don't know how to handle" cr ;
  496: 
  497: ' (dosee) IS dosee
  498: 
  499: : xtc ( xt -- )       \ do see at xt
  500:         Look 0= ABORT" SEE: No valid XT"
  501:         cr c-init
  502:         dosee ;
  503: 
  504: : see   name find 0= IF ." Word unknown" cr drop exit THEN
  505:         xtc ;
  506: 
  507: : lfc   cr c-init cell+ dosee ;
  508: : nfc   cr c-init dosee ;
  509: 
  510: 

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