summaryrefslogtreecommitdiffstats
path: root/qemu/roms/openbios/forth/debugging/see.fs
blob: 6977d29ebab517588fb3cdd4a5d2b3854accac36 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
\ tag: Forth Decompiler 
\ 
\ this code implements IEEE 1275-1994 ch. 7.5.3.2
\ 
\ Copyright (C) 2003 Stefan Reinauer
\ 
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\ 

1 value (see-indent) 

: (see-cr)
  cr (see-indent) spaces
  ;

: indent+
  (see-indent) 2+ to (see-indent)
  ;

: indent-
  (see-indent) 2- to (see-indent)
  ;
  
: (see-colon)
  dup ." : " cell - lfa2name type (see-cr)
   begin
   cell+ dup @ dup ['] (semis) <>
   while
    space
    dup
    case

      ['] do?branch of
        ." if" (see-cr) indent+
        drop cell+ 
      endof
      
      ['] dobranch of
      	." then" indent- (see-cr)
	drop cell+ 
      endof
      
      ['] (begin) of
        ." begin" indent+ (see-cr) 
	drop
      endof

      ['] (again) of
      	." again" (see-cr) 
	drop
      endof

      ['] (until) of
        ." until" (see-cr)
	drop
      endof

      ['] (while) of
        indent- (see-cr)
      	."  while" 
	indent+ (see-cr)
	drop 2 cells +
      endof

      ['] (repeat) of
        indent- (see-cr) 
        ."  repeat" 
	(see-cr) 
        drop 2 cells +
      endof

      ['] (lit) of
        ." ( lit ) h# " 
	drop 1 cells +
	dup @ u.
      endof

      ['] (") of
        22 emit space drop dup cell+ @ 
	2dup swap 2 cells + swap type 
	22 emit
	+ aligned cell+
      endof

      cell - lfa2name type 
    endcase
   repeat
  cr ."   ;"
  2drop
  ;

: (see) ( xt -- )
  cr
  dup @ case
    1 of 
      (see-colon)  
    endof
    3 of 
      ." constant " dup cell - lfa2name type ."  =  " execute . 
    endof
    4 of 
      ." variable " dup cell - lfa2name type ."  =  " execute @ . 
    endof
    5 of 
      ." defer " dup  cell - lfa2name type cr 
      ." is " cell+ @ cell - lfa2name type cr
    endof
    ." primword " swap cell - lfa2name type 
  endcase
  cr
  ;

: see ' (see) ;