-
Notifications
You must be signed in to change notification settings - Fork 2
/
INVOKEC.4TH
515 lines (426 loc) · 16 KB
/
INVOKEC.4TH
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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
// Invoke C(++) Functions
// Written by : Luke Lee
// Version 1.67
// update : 08/19/'95
// update : 09/19/'95
// update : 12/25/'95
// update : 01/02/'96
// update : 01/05/'96
// update : 01/28/'96
// update : 07/02/'96
// update : 11/06/'96 v1.66
// update : 01/20/'97 v1.67
// Last update : 02/13/'97 v1.67
// Written for DJGPP and Watcom C/C++
// Modification history :
// 09/19/'95 : Modify MACRO registration for SEE .
// 12/25/'95 : Add CLOCKS_PER_SECOND
// 01/02/'96 : Add 'struct tm' .
// 01/05/'96 : Use conditional compilation for both DJGPP and WATCOM.
// 01/28/'96 : Rename TRANSLATE-BLOCK into TRANSLATE .
// 07/02/'96 : Modify constant value of P_WAIT according to different compiler
// 11/06/'96 : Add patching for C(++) function 'forth_pause()'
// 01/20/'97 : Modify [ COMPILE exit ] to [ exit, ]
// 02/13/'97 : Modify for DJGPP_V2
: DJGPP_V2 ; INVISIBLE // 02/13/'97
// : DJGPP_GO32 ; INVISIBLE
// : WATCOM_C/C++ ; INVISIBLE
DECIMAL
VOCABULARY C++
C++ ALSO DEFINITIONS
$FF00 CONSTANT UNKNOWN // only the number of input parameters
// could possibly be unknown
0 CONSTANT void
1 CONSTANT int
1 CONSTANT unsigned
1 CONSTANT long
1 CONSTANT char*
1 CONSTANT void*
1 CONSTANT pointer
$F000 CONSTANT Floating
$F001 CONSTANT float // 32bit floating NOT implemented yet
$F002 CONSTANT double
: CLEAN1 COMPILE DROP ; : CLEAN2 COMPILE 2DROP ;
: CLEAN3 COMPILE 3DROP ; : CLEAN4 COMPILE 4DROP ;
: CLEAN5 COMPILE 5DROP ; : CLEAN6 COMPILE 6DROP ;
: CLEAN7 COMPILE 7DROP ; : CLEAN8 COMPILE 8DROP ;
CREATE CLEAN-UP
' CLEAN1 , ' CLEAN2 , ' CLEAN3 , ' CLEAN4 ,
' CLEAN5 , ' CLEAN6 , ' CLEAN7 , ' CLEAN8 ,
: (LayDownCleanUp) ( in -- )
DUP 0> IF
DUP 2/ 2/ 2/ 0 ?DO CLEAN8 LOOP
1- 7 AND CELL* CLEAN-UP + @EXECUTE
ELSE
DROP
ENDIF ; 1 0 #PARMS // caller should always do clean-ups
: LayDownCleanUp ( in -- ) RECURSIVE
DUP UNKNOWN >= IF DROP EXIT ENDIF
(LayDownCleanUp) ; 1 0 #PARMS
CREATE function-name$ 64 ALLOT
: too_many_return_values!
CR ." * Too many return values : " .
." for " LAST @ .ID
CR ABORT ;
: int_settle_return_value ( in out -- )
CASE
0 OF 1+ LayDownCleanUp ENDOF
1 OF DUP UNKNOWN < IF
CASE
0 OF NOOP ENDOF
1 OF COMPILE NIP ENDOF
( default : )
COMPILE >R
DUP LayDownCleanUp
COMPILE R>
ENDCASE
ELSE
DROP
ENDIF ENDOF
too_many_return_values!
ENDCASE ; 2 0 #PARMS
#DEFINED DJGPP_GO32
#DEFINED DJGPP_V2 OR
#IF
: float_settle_return_value ( in out -- ) // for DJGPP
Floating NOT AND
CASE
0 OF 2 + LayDownCleanUp ENDOF
1 OF 1+ LayDownCleanUp
COMPILE SF>TOS ENDOF
2 OF 1+ LayDownCleanUp
COMPILE DF>TOS ENDOF
too_many_return_values!
ENDCASE ; 2 0 #PARMS
#ELSE #DEFINED WATCOM_C/C++ #IF
: float_settle_return_value ( in out -- ) // for Watcom C++
Floating NOT AND
CASE
0 OF 2 + LayDownCleanUp ENDOF
1 OF 1 int_settle_return_value ENDOF
2 OF COMPILE >R LayDownCleanUp COMPILE R>
COMPILE EDX>STACK ENDOF
too_many_return_values!
ENDCASE ; 2 0 #PARMS
#ELSE
CR .( * Error : Unknown loader .) CR BEEP ABORT
#ENDIF #ENDIF
// ----------------------------------------
// postfix function implementation
// ----------------------------------------
$20 CONSTANT C++POSTFIX
: Postfix_C_func ( -- )
C++POSTFIX MaskNameAttr ; 0 0 #PARMS
: postfix-function ( in out C++fnadr -- FORTHfnadr )
function-name$ COUNT "HEADER OVERT
HERE >R
\ LITERAL COMPILE C(++)invoke // invoke fnadr
2DUP #PARMS
DUP Floating AND Floating = IF
float_settle_return_value
ELSE
int_settle_return_value
ENDIF
exit, // 01/20/'97
R> HERE OVER - LAST @ |SIZE !
MACRO Postfix_C_func ; 3 1 #PARMS
// ----------------------------------------
// Infix function implementation
// ----------------------------------------
STACK-EXPRESSION ALSO C++
$40 CONSTANT C++INFIX
VARIABLE funcall-nesting
STRUCT: ParsingFrame // 6 CELLS, allow nesting C++ function calls
WORD: |old-(|SP|)
WORD: |old-^parameter
WORD: |old-eval
WORD: |in
WORD: |out
WORD: |fnadr
;STRUCT
// Top down allocation :
CREATE transient-parameter 260 ALLOT
transient-parameter VALUE ^transient
// Bottom up allocation :
CREATE parameter-buffer 4 K ALLOT <LF> C, 64 ALLOT
parameter-buffer 4 K + CONSTANT end-parameter-buffer
end-parameter-buffer VALUE ^parameter
CREATE ParsingStack SIZEOF ParsingFrame 16 * ALLOT
HERE CONSTANT EndParsingStack
EndParsingStack SIZEOF ParsingFrame - CONSTANT LastParsingStackItem
EndParsingStack VALUE ParsingStack^
: InitParser ( -- )
funcall-nesting OFF
transient-parameter => ^transient
end-parameter-buffer => ^parameter
EndParsingStack => ParsingStack^ ; 0 0 #PARMS
: PopFrame ( -- )
ParsingStack^ |old-eval @ 'EVAL !
ParsingStack^ |old-^parameter @ => ^parameter
ParsingStack^ SIZEOF ParsingFrame LITERAL + => ParsingStack^
; 0 0 #PARMS
: AbortTranslation ( -- )
LastParsingStackItem |old-eval @ 'EVAL !
funcall-nesting OFF
InitParser CR ABORT ; 0 0 #PARMS
: C++SyntaxError ( -- )
CR ." Syntax error in nesting C(++) function call." CR
AbortTranslation ; 0 0 #PARMS
: check-#inparms (| #inpars | defined#ins -- |)
StkExprUsed?
ANDTHEN
ParsingStack^ |in @ => defined#ins
defined#ins UNKNOWN <>
ANDTHEN
defined#ins #inpars - 0<>
ANDTHEN
TRUE CR ." Error : Too "
defined#ins #inpars - 0< IF ." many" ELSE ." less" ENDIF
." parameters in C(++) function call : " #inpars . CR
AbortTranslation
THEN-AND DROP ;
: indefinite-inputs-cleanup (| #inpars -- |)
StkExprUsed?
ANDTHEN
ParsingStack^ |in @ UNKNOWN =
ANDTHEN
ParsingStack^ |out @ 0 ?DO COMPILE >R LOOP
#inpars (LayDownCleanUp)
ParsingStack^ |out @ 0 ?DO COMPILE R> LOOP
TRUE
THEN-AND DROP ;
: TranslateParameters (| | len #inpars -- |)
LastParsingStackItem |old-eval @ 'EVAL !
ParsingStack^ |old-^parameter @ ^parameter - => len
#LINESREAD @ >R
^parameter len TRANSLATE (( -- ERR? ))
R> #LINESREAD !
(( ERR? )) DUP IF COUNT TYPE AbortTranslation ELSE DROP ENDIF
(|SP|) @ ParsingStack^ |old-(|SP|) @ - => #inpars
#inpars check-#inparms
ParsingStack^ |fnadr @ compile,
#inpars indefinite-inputs-cleanup
PopFrame ;
: is","? ( $str -- T/F ) $" ," 2 COMP 0= ; 1 1 #PARMS
: is")"? ( $str -- T/F ) $" )" 2 COMP 0= ; 1 1 #PARMS
: is");"? ( $str -- T/F ) $" );" 3 COMP 0= ; 1 1 #PARMS
: >trailing (( c -- ))
^transient C!
^transient 1+ => ^transient ; 1 0 #PARMS
: trailing-" (| -- |) ASCII " >trailing ;
: trailing-bl (| -- |) BL >trailing ;
: copy-word ( $str -- ) // always lay down a blanket at end.
DUP COUNT ^transient SWAP CMOVE
C@ ^transient + => ^transient
trailing-bl ; 1 0 #PARMS
: copy-parameter (| | len -- |)
^transient transient-parameter - => len
len IF
^parameter len - => ^parameter
transient-parameter ^parameter len CMOVE
transient-parameter => ^transient
ENDIF ;
: scanfor-" ( str$ -- T/F ) // return TRUE if found
DUP COUNT
FOR
DUP C@ ASCII " <>
WHILE
1+
NEXT
2DROP FALSE
ELSE
RDROP ( FOR...NEXT ) DROP copy-word
ASCII " PARSE (( skip BL in TIB ))
^transient 1- PACK$ (( skip trailing BL in ^transcient ))
DUP COUNT + => ^transient
BL SWAP C! // change string length into BL
trailing-" // insert trailing " back
trailing-bl // also a trailing BL
TRUE
THEN ; 1 1 #PARMS
: is-word-, (| str$ -- T/F |) // return TRUE if it is ","
funcall-nesting @ 0=
ANDTHEN
str$ is","?
ANDTHEN
copy-parameter TRUE
THEN-AND => T/F ;
: is-word-) (| str$ -- T/F |) // return TRUE if it is ")"
str$ is")"?
ANDTHEN
funcall-nesting @ 0<> DUP IF
OVER copy-word
-1 funcall-nesting +!
funcall-nesting @ 0< IF C++SyntaxError ENDIF
ELSE
trailing-bl copy-parameter
funcall-nesting OFF
TranslateParameters
ENDIF
THEN-AND => T/F ; 1 1 #PARMS
: is-word-); (| str$ -- T/F |) // return TRUE if it is ");"
str$ is");"?
ANDTHEN
funcall-nesting @ 0= DUP IF
trailing-bl copy-parameter
funcall-nesting OFF
TranslateParameters
ELSE
C++SyntaxError
ENDIF
THEN-AND => T/F ; 1 1 #PARMS
: is-C++? (| str$ | ha/F -- T/F |)
// Allow nesting C++ function calls .
str$ FIND NIP => ha/F // Search current ORDER
ha/F
ANDTHEN
ha/F |ATTRIBUTE H@ C++INFIX AND C++INFIX =
ANDTHEN
str$ copy-word
1 funcall-nesting +! TRUE
THEN-AND => T/F ;
: ParseParameter ( str$ -- )
// 1. Scan for string pattern : "....."
DUP scanfor-" ORELSE
// 2. If it is the word ","
DUP is-word-, ORELSE
// 3. It is not ",", check if it is ")"
DUP is-word-) ORELSE
// 4. It is not ")", check if it is ");"
DUP is-word-); ORELSE
// 5. A C++ function ?
DUP is-C++? ORELSE
// 6. Not any situation above, copy word into transient parameter.
DUP copy-word 0 ELSE-OR 2DROP ; 1 0 #PARMS
: infix-function ( in out FORTHfnadr -- )
function-name$ " (" $+ COUNT
"CREATE
, , ,
C++INFIX MaskNameAttr INVISIBLE IMMEDIATE COMPILEONLY 0 0 #PARMS
DOES> ( -- )
DUP @ SWAP CELL+ DUP @ SWAP CELL+ @ ( fnadr out in )
'EVAL @ ^parameter (|SP|) @ ( fnadr out in 'EVAL@ ^par LSP@ )
ParsingStack^ 6 CELL* - => ParsingStack^
SP@ ParsingStack^ 6 CELL* CMOVE 6DROP
['] ParseParameter 'EVAL ! ; 3 0 #PARMS
FORTH DEFINITIONS
: C: ( in out C++fnadr -- )
>R 2DUP R>
BL WORD function-name$ 64 CMOVE
postfix-function
infix-function ; 3 0 #PARMS
: C& ( -- ) ( TIB: <function_name> -- ) // state smart !!
' DUP >HEAD |ATTRIBUTE H@ C++POSTFIX AND 0<> IF
SIZEOF (LIT) LITERAL 1- + @
STATE @ IF \ LITERAL ENDIF
ELSE
DROP CR ." * ERROR : C& must be applied on a C(++) function name " CR
ABORT
ENDIF ; IMMEDIATE 0 1 #PARMS
C++ DEFINITIONS
VARIABLE BUFSIZE
2 int BASE-ADDRESS |INIT-ENVIRON |C(++)Linking() @ C: C(++)Linking
void void
BASE-ADDRESS |INIT-ENVIRON |C(++)EndLinking() @ C: C(++)EndLinking
: Establish-Linkage ( -- )
['] <forth_interpret> BUFSIZE C(++)Linking
BUFSIZE @ TRANSLATE (( -- T/F ))
C(++)EndLinking
IF
." * Fail establishing linkage between FORTH and C(++)." CR
ENDIF ;
// Link FORTH and C(++) functions
Establish-Linkage
// Setup 'PAUSE' for C(++) multitasking // 11/06/'96
: "forth_pause()"patcher ( -- )
// [ $56 C, $57 C, ] // ESI PUSH EDI PUSH
[ $60 C, ] // PUSHAD
TASK @ UP! PAUSE
[ $61 C, ] // PUSHAD
// [ $5F C, $5E C, ] // EDI POP ESI POP
; 0 0 #PARMS INVISIBLE
: ReconnectLinkage ( -- )
reconnect_linkage( ['] <forth_interpret> )
['] "forth_pause()"patcher C& forth_pause (PATCH) ; 0 0 #PARMS
ReconnectLinkage
STRUCT: tm
WORD: |tm_sec // seconds after the minute [0-60]
WORD: |tm_min // minutes after the hour [0-59]
WORD: |tm_hour // hours since midnight [0-23]
WORD: |tm_mday // day of the month [1-31]
WORD: |tm_mon // months since January [0-11]
WORD: |tm_year // years since 1900
WORD: |tm_wday // days since Sunday [0-6]
WORD: |tm_yday // days since January 1 [0-365]
WORD: |tm_isdst // Daylight Savings Time flag
__sizeof_tm OFFSET |tm_isdst - CELL-
0 MAX FIELD: |_rest_of_tm
;STRUCT
: (ONLY) ( -- )
CONTEXT #VOCS CELL* 0 FILL
FORTH CONTEXT @ CONTEXT CELL+ ! C++ ALSO FORTH ; 0 0 #PARMS
' (ONLY) PATCH ONLY
#DEFINED DJGPP_GO32 #DEFINED DJGPP_V2 OR #IF
WARNING @ WARNING OFF
#EXISTED (dokey) #IF
HIDDEN ALSO C++ DEFINITIONS
2 VALUE curstype
: toggle-cursor
3 curstype XOR 3 AND DUP => curstype _setcursortype ; 0 0 #PARMS
is-insert? #IF toggle-cursor #ENDIF
: C++(dokey) ( buf #chars_got #max_got key -- #chars_got' #max_got' )
DUP ins = IF
toggle-cursor
ENDIF
DEFERS dokey ; 4 2 #PARMS
' C++(dokey) IS dokey
#ENDIF // #EXISTED (dokey)
WARNING !
#ENDIF // #DEFINED DJGPP_GO32
ONLY FORTH ALSO DEFINITIONS
// COLORS :
// dark colors :
0 CONSTANT BLACK 1 CONSTANT BLUE 2 CONSTANT GREEN
3 CONSTANT CYAN 4 CONSTANT RED 5 CONSTANT MAGENTA
6 CONSTANT BROWN 7 CONSTANT LIGHTGRAY
// light colors :
8 CONSTANT DARKGRAY 9 CONSTANT LIGHTBLUE 10 CONSTANT LIGHTGREEN
11 CONSTANT LIGHTCYAN 12 CONSTANT LIGHTRED 13 CONSTANT LIGHTMAGENTA
14 CONSTANT YELLOW 15 CONSTANT WHITE
$80 CONSTANT BLINK
// Other constants
#EXISTED DJGPP_V2 #EXISTED DJGPP_GO32 OR #IF
1 CONSTANT P_WAIT
3 CONSTANT P_OVERLAY
#ELSE #EXISTED WATCOM_C/C++ #IF // 07/02/'96 modified
0 CONSTANT P_WAIT
#ENDIF #ENDIF
-1 CONSTANT EOF
#EXISTED clock( #EXISTED DJGPP_GO32 AND
#IF
1000000 CONSTANT CLOCKS_PER_SEC // defined in <time.h>
clock DROP // initialize
: MS ( n -- ) // pause for n MS
[ CLOCKS_PER_SEC 1000 / ] LITERAL *
clock
BEGIN PAUSE
2DUP clock - ABS <=
UNTIL 2DROP ; 1 0 #PARMS
#ENDIF
#EXISTED clock( #EXISTED WATCOM_C/C++ AND
#EXISTED clock( #EXISTED DJGPP_V2 AND OR
#IF
#DEFINED WATCOM_C/C++ #IF
100 CONSTANT CLOCKS_PER_SEC // defined in <time.h>
#ELSE
91 CONSTANT CLOCKS_PER_SEC
#ENDIF
clock DROP // initialize
: MS ( n -- ) // pause for n MS, minimum available amount is 10 MS
[ CLOCKS_PER_SEC ] LITERAL 1000 */
clock
BEGIN PAUSE
2DUP clock - ABS <=
UNTIL 2DROP ; 1 0 #PARMS
#ENDIF