Annotation of gforth/see.fs, revision 1.6

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: 
1.6     ! pazsan    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: 
1.1       anton     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-;code               \ 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,
1.6     ! pazsan    386:         ' flit A,        ' c-flit A,
1.1       anton     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,
1.2       pazsan    400:         ' ;s A,          ' c-exit A,
1.1       anton     401:         ' (;code) A,     ' c-;code 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?
1.3       pazsan    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
1.1       anton     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 ;
1.4       pazsan    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
1.1       anton     468:          here @ look 0= ABORT" SEE: No valid xt in defered word"
1.4       pazsan    469:         here @ look drop dosee cr
                    470:         ." ' " .name r> ." IS " .name cr ;
1.5       pazsan    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
1.1       anton     474:         ScanMode c-pass ! dup makepass
                    475:         DisplayMode c-pass ! makepass ;
1.4       pazsan    476: : doali here @ .name ." Alias " .name cr
1.1       anton     477:         here @ dosee ;
                    478: : docol S" : " Com# .string
1.3       pazsan    479:         dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit
1.1       anton     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,
1.4       pazsan    495:        Use# ,   ' douse A,
1.1       anton     496:         0 ,
                    497: 
                    498: : (dosee) ( lfa -- )
1.4       pazsan    499:         dup dup cell+ c@ >r
1.1       anton     500:         wordinfo
                    501:         wordtypes
                    502:         BEGIN dup @ dup
1.4       pazsan    503:         WHILE 2 pick = IF cell+ @ nip EXECUTE
                    504:                          r> dup 32 and IF ."  immediate" THEN
                    505:                                 64 and IF ."  restrict" THEN EXIT THEN
1.1       anton     506:               2 cells +
                    507:         REPEAT
1.4       pazsan    508:         2drop rdrop
1.1       anton     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 ;
1.3       pazsan    517: 
1.4       pazsan    518: : see   name sfind 0= IF ." Word unknown" cr exit THEN
1.3       pazsan    519:         xtc ;
1.1       anton     520: 
                    521: : lfc   cr c-init cell+ dosee ;
                    522: : nfc   cr c-init dosee ;
                    523: 
                    524: 

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