-
Notifications
You must be signed in to change notification settings - Fork 0
/
conres.fth
123 lines (92 loc) · 3.78 KB
/
conres.fth
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
115
116
117
118
119
120
121
122
123
\ Conditions and restarts
\ From folklore
: CELL- [ 1 CELLS ] LITERAL - ;
\ From folklore
: +CONSTANT CREATE , DOES> @ + ;
\ From folklore
: ," [CHAR] " PARSE HERE OVER ALLOT SWAP CMOVE ;
\ From Wil Baden's TOOLBELT 2002
: ANDIF POSTPONE DUP POSTPONE IF POSTPONE DROP ; IMMEDIATE
\ From Gforth, for correct backtraces
: NOTHROW ['] FALSE CATCH 2DROP ;
\ Frame stack
CREATE FSTACK 32 CELLS ALLOT FSTACK CELL- CONSTANT FP0
VARIABLE FP FP0 FP !
: FP@ ( -- fp ) FP @ ;
: >F ( x -- ) FP @ CELL+ DUP FP ! ! ;
: F> ( -- x ) FP @ DUP CELL- FP ! @ ;
: @F ( fp n -- x ) CELLS - @ ;
\ Stack-preserving THROW and CATCH
\ Implementation using RP@ / RP! and SP@ / SP!, does not account
\ for locals or floats:
\
\ VARIABLE CATCHER
\ : CATCH FP @ >R CATCHER @ >R RP@ CATCHER ! EXECUTE
\ R> CATCHER ! R> FP ! FALSE ;
\ : THROW CATCHER @ RP! R> CATCHER ! R> FP ! TRUE ;
\ : MARK POSTPONE SP@ POSTPONE >R ; IMMEDIATE
\ : TRIM POSTPONE R> POSTPONE SP! ; IMMEDIATE
VARIABLE CATCHDEPTH VARIABLE STASHDEPTH
CREATE STASH 32 CELLS ALLOT
: THROW ( -* )
DEPTH CATCHDEPTH @ - DUP STASHDEPTH ! >R STASH BEGIN
R@ 0 > WHILE TUCK ! CELL+ R> 1- >R REPEAT DROP R> DROP
1 THROW ;
: CATCH ( ... xt -- ... f )
CATCHDEPTH @ >R DEPTH 1- CATCHDEPTH ! FP @ >R CATCH
R> FP ! R> CATCHDEPTH ! ( ... error ) DUP 1 = IF DROP
STASHDEPTH @ DUP >R CELLS STASH + BEGIN R@ 0 > WHILE
CELL- DUP @ SWAP R> 1- >R REPEAT DROP BEGIN
R@ 0 < WHILE DROP R> 1+ >R REPEAT R> DROP TRUE
ELSE DUP IF THROW THEN THEN ;
: MARK POSTPONE DEPTH POSTPONE >R ; IMMEDIATE
: (TRIM) >R BEGIN DEPTH R@ U> WHILE DROP REPEAT R> DROP ;
: TRIM POSTPONE R> POSTPONE (TRIM) ; IMMEDIATE
\ SIGNAL, RESPOND, and PASS
VARIABLE RESPONSE
: SIGNAL RESPONSE @ DUP 0 @F EXECUTE ;
: RESPOND ( ... xt response-xt -- ... )
RESPONSE @ >F >F FP@ RESPONSE ! CATCH ( ... f )
F> DROP F> RESPONSE ! IF THROW THEN NOTHROW ;
: (PASS) 1 @F DUP 0 @F EXECUTE ;
: PASS ( rf -* ) POSTPONE (PASS) POSTPONE EXIT ; IMMEDIATE
\ ESCAPE and RESUME
: ESCAPE ( tag -* ) POSTPONE THROW ; IMMEDIATE
: RESUME ( ... xt -- ... f )
FP@ SWAP 0 >F CATCH ( ... 0 | tag -1 ) F> DROP
DUP ANDIF OVER FP@ <> THEN IF DROP THROW THEN NOTHROW
DUP IF NIP THEN ;
\ the 0 ensures different RESUMEs have different tags
\ Class system
HERE CELL+ DUP , 1 CELLS , CONSTANT TOP
: CLONE ( c "name" -- ) DUP >R CREATE HERE >R DUP @
TUCK - SWAP [ 2 CELLS ] LITERAL + DUP , R> + , BEGIN
DUP R@ < WHILE DUP @ , CELL+ REPEAT @ CELL+ , R> DROP
DOES> DUP @ + ;
: EXTENDS ( c1 c2 -- ) OVER @ OVER @ MIN ROT SWAP - @ = ;
: METHOD ( xt "name" -- ) ( ... c -- ... c )
CREATE , DOES> >R DUP R> @ EXECUTE @ EXECUTE ;
\ HANDLE
: (HANDLE) ( ... c fp -- ... ) 2DUP 2 @F EXTENDS IF
DUP 3 @F EXECUTE ELSE PASS THEN ;
: HANDLE ( ... xt c handler-xt -- ... ) >F >F
['] (HANDLE) RESPOND F> DROP F> DROP ;
1 CELLS +CONSTANT >UNHANDLED ' >UNHANDLED METHOD UNHANDLED
2 CELLS +CONSTANT >DISPLAY ' >DISPLAY METHOD DISPLAY
: DEFAULT-RESPONSE ( с rf ) DROP UNHANDLED ;
' DEFAULT-RESPONSE >F FP@ RESPONSE !
: UNHANDLED-? ." Unhandled " DISPLAY ABORT ;
: DISPLAY-? ." bug" ;
TOP CLONE ? ' UNHANDLED-? , ' DISPLAY-? ,
\ RESTART
: ((RESTART)) ( ... c hf -* ) 4 @F ESCAPE ;
: (RESTART) ( ... xt c tag -- ... )
>F ['] ((RESTART)) HANDLE F> DROP ;
: RESTART ( ... xt c -- ... f ) ['] (RESTART) RESUME ;
3 CELLS +CONSTANT >NAME
5 CELLS +CONSTANT >DESCRIBE ' >DESCRIBE METHOD DESCRIBE
: DISPLAY-RESTART? ." bug: no restart " DUP >NAME 2@ TYPE ;
HERE ," RESTART?" DUP HERE SWAP -
: DESCRIBE-RESTART? ." Unspecified restart" ;
? CLONE RESTART? ( ... c -- restart? ) ? >UNHANDLED @ ,
' DISPLAY-RESTART? , ( c-addr len ) , , ' DESCRIBE-RESTART? ,