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>