Annotation of gforth/see.fs, revision 1.4

1.1       anton       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,
1.2       pazsan    389:         ' ;s A,          ' c-exit A,
1.1       anton     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?
1.3       pazsan    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
1.1       anton     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 ;
1.4     ! pazsan    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
1.1       anton     457:          here @ look 0= ABORT" SEE: No valid xt in defered word"
1.4     ! pazsan    458:         here @ look drop dosee cr
        !           459:         ." ' " .name r> ." IS " .name cr ;
        !           460: : dodoe ." Create " .name cr
1.1       anton     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 ;
1.4     ! pazsan    465: : doali here @ .name ." Alias " .name cr
1.1       anton     466:         here @ dosee ;
                    467: : docol S" : " Com# .string
1.3       pazsan    468:         dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit
1.1       anton     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,
1.4     ! pazsan    484:        Use# ,   ' douse A,
1.1       anton     485:         0 ,
                    486: 
                    487: : (dosee) ( lfa -- )
1.4     ! pazsan    488:         dup dup cell+ c@ >r
1.1       anton     489:         wordinfo
                    490:         wordtypes
                    491:         BEGIN dup @ dup
1.4     ! pazsan    492:         WHILE 2 pick = IF cell+ @ nip EXECUTE
        !           493:                          r> dup 32 and IF ."  immediate" THEN
        !           494:                                 64 and IF ."  restrict" THEN EXIT THEN
1.1       anton     495:               2 cells +
                    496:         REPEAT
1.4     ! pazsan    497:         2drop rdrop
1.1       anton     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 ;
1.3       pazsan    506: 
1.4     ! pazsan    507: : see   name sfind 0= IF ." Word unknown" cr exit THEN
1.3       pazsan    508:         xtc ;
1.1       anton     509: 
                    510: : lfc   cr c-init cell+ dosee ;
                    511: : nfc   cr c-init dosee ;
                    512: 
                    513: 

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