-
Notifications
You must be signed in to change notification settings - Fork 2
/
HI.4TH
772 lines (633 loc) · 24.3 KB
/
HI.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
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
// Miscellaneous high level words for Common Forth
// Written by : Luke Lee
// Last update : 01/23/'97
// ---------------------------------------------------------------------------
// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
// I M P O R T A N T N O T E S
// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
// Note that if you are trying to add some compiling words ( such as ASCII )
// into this HI.4TH and wish it would be compatiable with Stack Expression,
// you MUST insert it after Stack Expression is loaded.
// That is, you should add your own compiling words after the line :
// 'FLOAD StkExpr.4TH' .
// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
// --------------------------------------------------------------------------
// Modification history I rememberred (too many to record them all) :
// [8/20/'92] : Add DEFERS and modifies DEFER .
// [9/05/'92] : Add alias #I of R@, and modify the bug in ALIAS
// ( the I/O #PARMS must be the same too ) .
// [1/3/'93] : Add CASE ... OF ... ENDOF .. ENDCASE
// ERASE
// DO , ?DO , LOOP and LEAVE
// [2/23/'93] : Modify the CASE ... ENDCASE structure to be compatiable
// with standard structure.
// .
// . ( not recorded )
// .
// [8/4/'93] : Include SHORTCUT.4TH for short cut boolean evaluation.
// [8/19/'93] : Modify bugs in TRIM-VOC , Search-Entry and WORDS .
// [4/17/'94] : Add >HEAD
// [4/22/'94] : Load CASE.4TH after STKEXPR.4TH for CASE ... ENDCASE
// [4/23/'94] : VALUE words are now in stack-expression
// KEYBUF.4TH are now implemented and included here.
// [4/26/'94] : New FLOAD and $FLOAD for create filenames in vocabulary
// FILES .
// [5/6/'94] : Include NEEDS .
// [5/14/'94] : Multasker .
// [5/15/'94] : modify > < <= ... into MACROs
// [11/20/'94] : add 'PATCH' .
// [12/02/'94] : add 'CREATOR?' for CF0.4TH's DOES> modification
// .
// . ( not recorded )
// .
// [01/04/'96] : Modify COMMENT: ... ;COMMENT for running away comments.
// [01/16/'96] : Modify ASSERT.4TH for running away assertion.
// ...
// [03/10/'96] : Optimize ARRAY: for different case DOES> .
// [03/19/'96] : Move 2SWAP into CF0.4TH .
// [07/14/'96] : Modify HERROR$ for DPMI error messages.
// [11/15/'96] : Move disassembler CODE>HEAD here.
// [01/04/'97] : Add COMMENT-PAIR: words set.
// [01/20/'97] : Modify [ COMPILE exit ] to [ exit, ]
// [01/21''97] : Add [ DEFERRED ], ex:
// DEFER DFR ['] NOOP IS DFR
// DEFERRED DFR
// ['] WORDS IS DFR DFR
// IS DFR
// [01/23/'97] : Modify [ CREATOR? ] for more robust checking.
// --------------------------------------------------------------------------
WARNING OFF
DECIMAL
CR
.( ---------------------- Loading high level words -----------------------)
// *********** Structure defining words and Head Structure ************
CR .( Loading data structure defining words : STRUCT.4TH ...)
FLOAD STRUCT.4TH
FLOAD HEAD.4TH
// ******************** System memory map *********************
FLOAD MEMMAP.4TH // system memory map
.( ... ok)
// *************** Some commonly used words *****************
: valid-addr? ( a -- T/F )
BASE-ADDRESS BASE-ADDRESS |WORK-SPACE |FORTH-VOCTABLE
WITHIN ; 1 1 #PARMS
: CODE>HEAD ( ca -- ha|0 ) // Convert code address into head address if success,
// otherwise return 0.
DUP DUP valid-addr?
IF >HEAD DUP valid-addr?
IF 2DUP |REFERENCE @ =
IF
NIP EXIT
ENDIF
ENDIF
ENDIF 2DROP FALSE ; 1 1 #PARMS
0 CONSTANT NULL
0 CONSTANT NIL
: BINARY 2 BASE ! ; 0 0 #PARMS
: EXIT (( -- ))
STATE @ IF exit, ENDIF ; 0 0 #PARMS IMMEDIATE
: TUCK (( n1 n2 -- n2 n1 n2 ))
SWAP OVER ; MACRO 2 3 #PARMS
: ALIAS (( ca -- ))
CREATE
LAST @ 2DUP |REFERENCE ! // set reference field
OVER >HEAD |USER-DEFINED @ OVER |USER-DEFINED !
OVER >HEAD |ATTRIBUTE @ OVER |ATTRIBUTE ! // set attr...out-parms
SWAP |SIZE @ SWAP |SIZE ! ; 1 0 #PARMS
' R@ DUP ALIAS #I ALIAS I
: ERASE 0 FILL ; 2 0 #PARMS
: CMOVE> (( from to count -- ))
FOR
R@ + 1- SWAP R@ + 1- SWAP
AFT
OVER C@ OVER C! 1- SWAP 1- SWAP
THEN
NEXT 2DROP ; 3 0 #PARMS
: MOVE (( from to count -- ))
-ROT 2DUP U< IF
ROT CMOVE>
ELSE
ROT CMOVE
ENDIF ; 3 0 #PARMS
: BEEP (( -- ))
7 BIOSEMIT ; 0 0 #PARMS
: (VOC-FIND) (( stradr voc-table -- ca ha | stradr F ))
OVER 1+ HASH SWAP (FIND) // stradr ca ha | stradr key F
DUP IF
ROT DROP
ELSE
NIP
ENDIF ; 2 2 #PARMS INVISIBLE
// ******************* Vocabulary words *****************
CR .( Loading Vocabulary Definitions : VOCAB.4TH ...)
FLOAD VOCAB.4TH
.( ... ok)
VOCABULARY HIDDEN
HIDDEN ALSO DEFINITIONS
// *********************** Defer words ********************
: CRASH (( -- ))
." Uninitialized vector !" CR ABORT ; 0 0 #PARMS
FORTH DEFINITIONS
: CREATOR? ( creator created -- T/F ) // 01/23/'97 modified
DUP ['] call [ ' call >HEAD |SIZE @ 1- ] LITERAL COMP 0= IF
1+ DUP @ + (( CELL+ CELL- )) @ =
ELSE
2DROP FALSE
ENDIF ; 2 1 #PARMS
: DEFER ( -- )
CREATE
$FF $FF #PARMS
['] CRASH ,
DOES>
@EXECUTE ; 0 0 #PARMS
: 'DEFER ( -- ca )
// Tick for defer words, check whether it is defined by DEFER.
' ['] DEFER OVER CREATOR? NOT IF
." Can't defers a non-deferred word " >HEAD .ID ." ." CR ABORT
ENDIF ; 0 1 #PARMS INVISIBLE
: DEFERS ( -- ) ( TIB: <NAME> -- )
'DEFER
>BODY @ compile,
; 0 0 #PARMS IMMEDIATE COMPILEONLY
: >DEFERRED ( defer_ca -- deferred_ca ) >BODY @ ; 1 1 #PARMS
: DEFERRED ( -- ca )
STATE @ IF
'DEFER >BODY \ LITERAL COMPILE @
ELSE
'DEFER >DEFERRED
ENDIF ; IMMEDIATE 0 1 #PARMS
: IS ( ca -- )
STATE @ IF
' >BODY \ LITERAL COMPILE !
ELSE
' >BODY !
ENDIF ; IMMEDIATE 1 0 #PARMS
// ***************** COMMENT: and ;COMMENT *******************
// Note :
// ';COMMENT' must be placed as the first word of that line, otherwise
// it won't make any effect
// Ex.
// COMMENT:
// THIS IS A COMMENT
// HERE ;COMMENT HAS NO EFFECT
// COMMENT: HERE HAS NO EFFECT EITHER
// THIS IS ANOTHER COMMENT
// ;COMMENT // HERE ;COMMENT WORKS
VARIABLE CommentSaved'EVAL ' NOOP CommentSaved'EVAL !
2VARIABLE CommentResetter
: ResetComments (( -- ))
['] NOOP CommentSaved'EVAL !
CommentResetter POP-RESETTER ; 0 0 #PARMS
FORTH DEFINITIONS
: ;COMMENT (( -- ))
TRUE ABORT" Not commenting" ; 0 0 #PARMS IMMEDIATE
: COMMENT; (( -- )) // just for compatiability
\ ;COMMENT ; 0 0 #PARMS IMMEDIATE INVISIBLE
HIDDEN DEFINITIONS
DEFER CommentPairing? ( a -- T/F ) 1 1 #PARMS
: FailCommentPairing ( a -- T/F ) DROP FALSE ; 1 1 #PARMS
' FailCommentPairing IS CommentPairing?
: EndComments ( -- )
CommentSaved'EVAL @ 'EVAL !
ResetComments ; 0 0 #PARMS
: $SKIP-COMMENTS ( A -- )
DUP ['] ;COMMENT >NAME $=
OVER ['] COMMENT; >NAME $= OR
OVER CommentPairing? OR NIP
IF
EndComments
ELSE
\ //
ENDIF ; 1 0 #PARMS
: CommentsRunAway? (( -- ))
CommentSaved'EVAL @ ['] NOOP <> IF
EndComments
CR ." * Error : Run away comments , COMMENT: without ;COMMENT ." CR
ABORT
ENDIF ; 0 0 #PARMS
FORTH DEFINITIONS
: COMMENT: (( -- ))
['] ResetComments CommentResetter PUSH-RESETTER
'EVAL @ CommentSaved'EVAL !
['] $SKIP-COMMENTS 'EVAL !
\ // ; IMMEDIATE 0 0 #PARMS
: COMMENTS-PAIR: ( -- )
( TIB: <comment-begin> <comment-end> -- ) // 01/04/'97
>IN @ TOKEN C@ 0<> TOKEN C@ 0<> AND SWAP >IN !
NOT IF CR ." * Error : Comments not paired." CR ABORT ENDIF
['] COMMENT: ALIAS
CREATE
HERE // DUP aaaa $= SWAP DEFERS CommentPairing? OR EXIT
COMPILE DUP LAST @ |NAME-LENGTH \ LITERAL COMPILE $=
COMPILE SWAP
['] CommentPairing? >BODY @ call, // DEFERS CommentPairing?
COMPILE OR exit,
IS CommentPairing?
DOES>
\ ;COMMENT ; 0 0 #PARMS
// ********************* Floaded file names *******************
HIDDEN DEFINITIONS
DEFER ENDOF$FLOAD 0 0 #PARMS
' CommentsRunAway? IS ENDOF$FLOAD
FORTH DEFINITIONS
VOCABULARY FILES
ALSO FILES DEFINITIONS
: HI.4TH ; : STRUCT.4TH ; : HEAD.4TH ; : MEMMAP.4TH ; : VOCAB.4TH ;
PREVIOUS DEFINITIONS
VARIABLE FILENAMES
FILENAMES ON
: $>UPPER (( str len -- ))
FOR AFT
DUP C@ [ CHAR a ] LITERAL [ CHAR z ] LITERAL BETWEEN
IF
[ CHAR A CHAR a - ] LITERAL OVER +! // no underflow possible
ENDIF
1+
THEN NEXT DROP ; 2 0 #PARMS
: $>LOWER (( str len -- ))
FOR AFT
DUP C@ [ CHAR A ] LITERAL [ CHAR Z ] LITERAL BETWEEN
IF
[ CHAR a CHAR A - ] LITERAL OVER +! // no overflow possible
ENDIF
1+
THEN NEXT DROP ; 2 0 #PARMS
: $FLOAD (( str len -- ))
FILENAMES @ IF
CURRENT @ -ROT ALSO FILES DEFINITIONS
RP@ DUP 2SWAP ROT OVER -
NEGATE ALIGNED NEGATE RP! // allocate temporary space on RStack
TUCK RP@ SWAP CMOVE
RP@ SWAP 2DUP $>UPPER
2DUP "HEADER OVERT $C3 C,
PREVIOUS 2SWAP SWAP CURRENT ! >R
$FLOAD R> RP! // free RStack by 'len' bytes
ELSE
$FLOAD
ENDIF
ENDOF$FLOAD ; 2 0 #PARMS INVISIBLE
: FLOAD (( -- ; <string> ))
RP@ TOKEN COUNT
RP@ OVER - 8 - // save space for PACK$ 's trailing zeros.
NEGATE ALIGNED NEGATE RP! // allocate string space on RStack
RP@ PACK$ SWAP >R
COUNT $FLOAD
R> RP! (( free RStack )) ; 0 0 #PARMS
: NEEDS (( -- ; <string> ))
RP@ TOKEN COUNT TUCK RP@ OVER - 8 -
NEGATE ALIGNED NEGATE RP!
RP@ PACK$ 1+ SWAP $>UPPER
>R
RP@ CELL+ ['] FILES >BODY @ (VOC-FIND) IF
DROP
ELSE
COUNT $FLOAD
ENDIF
R> RP! ; 0 0 #PARMS
// *********************** Multasking facilities **********************
CR .( Loading multasking facilities MULTASK.4TH ...)
FLOAD MULTASK.4TH
.( ... ok)
// ********************* Program tracing tool ********************
CR .( Loading Program Tracing Tool : TRACER.4TH ...)
FLOAD TRACER.4TH
.( ... ok)
// *************** Stack expression words *****************
CR .( Loading Stack Expression : StkExpr.4TH ...)
FLOAD StkExpr.4TH
.( ... ok)
// ********************* New compiling words *********************
: $" ( -- ; <string> ) // 01/12/'97
STATE @ IF
\ $"
ELSE
HERE $,"
ENDIF ; IMMEDIATE // A state-smart word which stack effect are not
// the same in compiling time or in interpreting
// time . So no '#PARMS' could be defined.
: Z$" ( -- ; <string> ) // 01/12/'97
STATE @ IF
\ Z$"
ELSE
HERE $," 0 C,
ENDIF ; IMMEDIATE
: " ( -- ; <string> ) // 01/12/'97
STATE @ IF
\ "
ELSE
HERE $," COUNT
ENDIF ; IMMEDIATE
: ASCII (( -- ))
CHAR STATE @ IF \ LITERAL ENDIF ; IMMEDIATE 0 0 #PARMS
BUG-WARNING OFF
// ************* CASE ... OF ... ENDOF ... ENDCASE ****************
CR .( Loading CASE.4TH ...)
FLOAD CASE.4TH
.( ... ok)
FORTH DEFINITIONS
// ********************** System image saving ************************
: HERROR$ (( err-code -- str len ))
CASE
$01 OF " Invalid mode" ENDOF
$02 OF " File not found" ENDOF
$03 OF " Path not found" ENDOF
$04 OF " Not enough file handles" ENDOF
$05 OF " Access denied" ENDOF
$06 OF " Invalid handle" ENDOF
$0C OF " Invalid access code" ENDOF
// DPMI error codes : 07/14/'96 added
$8001 OF " Unsupported function" ENDOF
$8002 OF " Invalid state" ENDOF
$8003 OF " System integrity" ENDOF
$8004 OF " Dead lock" ENDOF
$8005 OF " Request cancelled" ENDOF
$8010 OF " Resource Unavailable" ENDOF
$8011 OF " Descriptor unavailable" ENDOF
$8012 OF " Linear memory unavailable" ENDOF
$8013 OF " Physical memory unavailable" ENDOF
$8014 OF " Backing store unavailable" ENDOF
$8015 OF " Callback unavailable" ENDOF
$8016 OF " Handle unavailable" ENDOF
$8017 OF " Lock count exceeded" ENDOF
$8018 OF " Resource owned exclusively" ENDOF
$8019 OF " Resource owned shared" ENDOF
$8021 OF " Invalid value" ENDOF
$8022 OF " Invalid selector" ENDOF
$8023 OF " Invalid handle" ENDOF
$8024 OF " Invalid callback" ENDOF
$8025 OF " Invalid linear address" ENDOF
$8026 OF " Invalid request" ENDOF
ENDCASE ; 1 2 #PARMS
CR .( Loading FSAVE.4TH ...)
FLOAD FSAVE.4TH
.( ... ok)
// *************** Miscellaneous alias words ******************
FORTH DEFINITIONS
' CELL* ALIAS CELLS
' OVERT ALIAS REVEAL
' CP ALIAS DP
' @EXECUTE ALIAS PERFORM
' @ ALIAS HEAD>
' IF ALIAS ?{
' ELSE ALIAS }{
' ENDIF ALIAS }?
// ******************** FORGET and WORDS ************************
STACK-EXPRESSION ALSO HIDDEN DEFINITIONS
VARIABLE TOTAL-WORDS // for WORDS
VARIABLE FENCE // for (FORGET)
: HashTable? (( ha -- T/F ))
// check whether the head is a vocabulary hash table
>R FALSE VOC-LINK @ BEGIN
DUP @ R@ = IF
SWAP DROP TRUE DUP -ROT
ELSE
CELL+ @ DUP 0 =
ENDIF
UNTIL RDROP DROP ; 1 1 #PARMS
: Vocabulary? (( ha -- T/F ))
// check whether the head belongs to a vocabulary
DUP HEAD> >BODY @ |HASHTABLE| + = ; 1 1 #PARMS
: Search-Thread (( ha hashtab ^link -- last-^link T/F ))
SWAP >R (( ha ^link ;R: hashtab ))
BEGIN
SWAP OVER
@ DUP 0= IF RDROP NIP EXIT ENDIF
R@ + (( ^link ha ha' ;R: hashtab ))
2DUP <> WHILE
|LINK ROT DROP
REPEAT (( ^link ha ha' ;R: hashtab ))
RDROP 2DROP TRUE ; 3 2 #PARMS
: TRIM-ENTRY (( ha -- ha ))
// trim a head off
DUP |NAME-STRING HASH CELL* (( ha off ))
VOC-LINK @ (( ha off vbody ))
BEGIN
>R 2DUP OVER SWAP R@ @ SWAP OVER + (( ha off ha ha tab ^link ))
Search-Thread IF (( ha off ha ^link ))
SWAP |LINK @ SWAP ! FALSE // skip this entry
ELSE
2DROP TRUE
ENDIF (( ha off T/F ))
WHILE
R> CELL+ @ (( ha off vbody ))
DUP 0= ABORT" Vocabulary corrupted" // head not found
REPEAT
DROP RDROP ; 1 1 #PARMS
: TRIM-VOC (( ha -- ha )) // ha = head of vocabulary, trim off this vocabulary
DUP @ >BODY DUP CELL+ @ VOC-LINK !
// no need to check CURRENT since a vocabulary can't possibily inside
// itself, except FORTH which can never be trimed.
@ CONTEXT BEGIN
2DUP @ = IF
DUP CELL+ OVER OVER CURRENT SWAP - CMOVE
ELSE
CELL+
ENDIF
DUP @ 0= UNTIL 2DROP
CONTEXT CELL+ @ 0= IF CONTEXT @ CONTEXT CELL+ ! ENDIF ; 1 1 #PARMS
: TRIM-HEADS (( ha -- )) // Trim off all words later than this word
>R HP @ BEGIN (( ha' | ha ))
DUP HashTable? IF
|HASHTABLE| + TRIM-VOC
ELSE DUP Vocabulary? IF
TRIM-VOC
ENDIF ENDIF
TRIM-ENTRY
DUP |HEAD| + SWAP R@ =
UNTIL HP ! RDROP ; 1 0 #PARMS
: invalid-ha? (( ha -- ha T/F ))
DUP HEAD> >HEAD OVER <> ; 1 2 #PARMS
: ((FORGET)) (( ha -- ))
// perform forgetting
DUP HEAD> CELL-
SWAP TRIM-HEADS
CP ! ; 1 0 #PARMS
: (FORGET) (( ha -- ))
DUP HEAD> FENCE @ < ABORT" Below Fence "
invalid-ha? ABORT" Invalid address to forget"
((FORGET)) HP @ LAST ! ; 1 0 #PARMS
' (FORGET) IS (FORGET-HP)
VARIABLE AllWords?
FORTH DEFINITIONS
: (WORDS) (( -- ))
CR ." [ Vocabulary : " CONTEXT @ HASHTABLE>BODY BODY> >HEAD .ID ." ]"
CR 0 TOTAL-WORDS !
HP @ BEGIN (( ha ))
DUP DUP |NAME-STRING HASH CELL* (( ha ha off ))
CONTEXT @ SWAP OVER + (( ha ha tab ^link ))
Search-Thread NIP IF
DUP |ATTRIBUTE H@ INVIS-MASK AND 0= AllWords? @ OR
IF // invisible
DUP |NAME-LENGTH DUP C@ AT? DROP + 80 >= IF CR ENDIF
COUNT TYPE TAB 1 TOTAL-WORDS +! // display context[0] words
ENDIF
ENDIF
|HEAD| +
DUP HashTable? IF |HASHTABLE| + ENDIF
PAUSE
DUP HP0 = NUF? OR UNTIL DROP
CR ." [ Total " BASE @ DECIMAL TOTAL-WORDS @ . BASE !
." words displayed ]" CR ; 0 0 #PARMS INVISIBLE
: WORDS (( -- ))
AllWords? OFF (WORDS) ; 0 0 #PARMS
: ALLWORDS (( -- ))
AllWords? ON (WORDS) ; 0 0 #PARMS
: FORGET (( -- )) // 08/18/'93 modified, works only on CURRENT
TOKEN CURRENT @ (VOC-FIND) DUP IF
NIP (FORGET)
ELSE
DROP SPACE ASCII " EMIT COUNT TYPE ASCII " EMIT
." is not in CURRENT vocabulary. " CR ABORT
ENDIF ; 0 0 #PARMS
: UNLOAD (( -- )TIB: <filename> ) // 1/3/'95, 11/29/'95
RP@ TOKEN COUNT TUCK RP@ OVER - 8 -
NEGATE ALIGNED NEGATE RP!
RP@ PACK$ 1+ SWAP $>UPPER
>R
RP@ CELL+ ['] FILES >BODY @ (VOC-FIND) DUP IF
DUP (FORGET)
ENDIF
2DROP
R> RP! ; 0 0 #PARMS
: RELOAD (( -- )TIB: <filename> ) // 1/3/'95
>IN @ UNLOAD >IN ! NEEDS ; 0 0 #PARMS
// ***************** Special stack operation words ******************
COMMENT:
GCD with recurse :
: GCD-AUX (| M N -- G |) RECURSIVE // tail recursive
M N MOD >> G
G 0<> ?{ N G GCD-AUX }{ N }? >> G ;
: GCD (| M N -- G |)
M N < ?{ M >> G N >> M G >> N }?
M N GCD-AUX >> G ;
COMMENT;
HIDDEN DEFINITIONS
: GCD (| M N -- G |)
M N < ?{ M >> G N >> M G >> N }?
BEGIN
M N MOD >> G
G 0<> WHILE
N >> M G >> N
REPEAT
N >> G ;
: ?No<==> (| P1 P2 T/F -- |)
T/F IF
." Invalid argument for <==> : " P1 . P2 . ." ." CR ABORT
ENDIF ;
FORTH DEFINITIONS
: <==> (| OFFSET SIZE | G TOTAL ^CELL DIFF -- |) // EXCHANGE
// a generalized ROLL, but it does not need run-time argument for
// ROLLing, the offset and size for rolling is determined
// at compiling time .
OFFSET SIZE OFFSET $FF > SIZE $FF > OR SIZE OFFSET > OR ?No<==>
SIZE 0<> ?{ // size = 0, do nothing
OFFSET 1+ >> TOTAL
TOTAL SIZE GCD >> G
TOTAL SIZE - >> DIFF DIFF 1- >> ^CELL
TOTAL G / 1- FOR AFT
^CELL 0 = ?{
$87 C, $45 C, $00 C, // XCHG EAX,[EBP]
}{
$87 C, $85 C, ^CELL CELL* , // XCHG EAX, [EBP+^CELL*4]
}?
^CELL DIFF + TOTAL MOD >> ^CELL
THEN NEXT
G 1- FOR AFT
$8B C, $95 C, #I CELL* , // MOV EDX, [EBP+(I-1)*4]
OFFSET SIZE - #I 1+ + >> ^CELL
TOTAL G / 1- FOR AFT
$87 C, $95 C, ^CELL CELL* , // XCHG EDX, [EBP+^CELL*4]
^CELL DIFF + TOTAL MOD >> ^CELL
THEN NEXT
$89 C, $95 C, #I CELL* , // MOV [EBP+(I-1)*4], EDX
THEN NEXT
}? ;
// : 2SWAP ((| a b c d -- C D A B |)
// // pretty looking but inefficient
// a >> A b >> B c >> C d >> D ;
: 2OVER (( a b c d -- a b c d a b ))
[ 3 1 ARG@ 3 1 ARG@ ] ; 4 6 #PARMS
: 2ROT (( a b c d e f -- c d e f a b ))
[ 5 4 <==> ] ; 6 6 #PARMS
: TEST: (( -- ))
>IN @ BL WORD FIND DUP IF // duplicate words will be eliminated
DUP (FORGET)
ENDIF
2DROP >IN ! : ; 0 0 #PARMS
: ARRAY: (( cell_size #cells -- )TIB: <name> -- )
CREATE 1 1 #PARMS
OVER , OVER * DUP LAST @ |SIZE !
HERE OVER ERASE ALLOT
CASE // special case
1 OF DOES> + CELL+ EXIT ENDOF
2 OF DOES> SWAP 2* + CELL+ EXIT ENDOF
4 OF DOES> SWAP CELL* + CELL+ EXIT ENDOF
8 OF DOES> SWAP CELL* 2* + CELL+ EXIT ENDOF
16 OF DOES> SWAP CELL* CELL* + CELL+ EXIT ENDOF
256 OF DOES> SWAP 256* + CELL+ EXIT ENDOF
ENDCASE
DOES> (( index -- addr ))
TUCK @ * + CELL+ EXIT ; 2 0 #PARMS
: <PATCH> ( adr old-adr -- ) // patch old-adr to 'JMP adr'
$E9 OVER C! // laydown 'JMP'
1+ DUP CELL+ ROT SWAP - SWAP ! ; 2 0 #PARMS INVISIBLE
: (PATCH) ( ca old-ca -- ) // modified for patching C functions
DUP CODE>HEAD DUP 0<> IF
|SIZE 5 SWAP ! // size became 5, the rest codes became garbage.
ELSE
DROP
ENDIF
<PATCH> ; 2 0 #PARMS INVISIBLE
: PATCH (( ca -- )TIB: <target-name> )
// redirect <target-name>'s code into 'ca'
' DUP >HEAD |SIZE @
5 < ABORT" Target word's code size is too small (<5), can't PATCH"
STATE @ IF
\ LITERAL COMPILE (PATCH)
ELSE
(PATCH)
ENDIF ; 1 0 #PARMS IMMEDIATE
// New control structure : the #REPEATS: <New idea>
// Ex1:
// : TEST 10 #REPEATS: 1 2 + . ; <enter>
// TEST <enter>
// 3 3 3 3 3 3 3 3 3 3 3 ok
// Ex2:
// : TEST #REPEATS: 2 + DUP . ; <enter>
// 10 5 TEST <enter>
// 12 14 16 18 20 ok
// . <enter>
// 20 ok
: #REPEATS: (( n -- ))
// execute the codes between '#REPEATS:' and ';' N times.
R> SWAP
FOR AFT
DUP >R EXECUTE R>
THEN NEXT DROP ; COMPILEONLY
// ******************** DO-LOOP words ***********************
CR .( Loading DOLOOP.4TH ...)
FLOAD DOLOOP.4TH
.( ... ok)
// *************** Short-cut boolean evaluation *****************
CR .( Loading short-cut boolean evaluation : SHORTCUT.4TH ...)
FLOAD SHORTCUT.4TH
.( ... ok)
// ********************** Conditional Compilation *********************
CR .( Loading conditional compilation words #IF.4TH ...)
FLOAD #IF.4TH
.( ... ok)
CR .( Loading assertion defining tool ASSERT.4TH ...)
FLOAD ASSERT.4TH
.( ... ok)
HIDDEN ALSO
HERE FENCE !
// **************** Command history recording ****************
CR .( Loading line editor KEYBUF.4TH ...)
FLOAD KEYBUF.4TH
.( ... ok)
ONLY FORTH ALSO DEFINITIONS
WARNING ON // for duplicate names
BUG-WARNING ON // for stack expression
CR
.( ------------------- Finish loading high level words --------------------)