Annotation of gforth/see.fs, revision 1.1

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,
        !           389:         ' exit 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= ABORT" SEE: Bua!"
        !           431:            cell+ dup count 31 and rot wordinfo .string 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:         cell+ dup 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 cell+ dup 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: : see   name find cr 0= IF ." Word unknown" cr drop exit THEN
        !           500:         >name c-init
        !           501:         dosee ;
        !           502: 
        !           503: : xtc ( xt -- )       \ do see at xt
        !           504:         Look 0= ABORT" SEE: No valid XT"
        !           505:         cr c-init
        !           506:         dosee ;
        !           507: 
        !           508: : lfc   cr c-init cell+ dosee ;
        !           509: : nfc   cr c-init dosee ;
        !           510: 
        !           511: 

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