1: \ EXTEND.FS CORE-EXT Word not fully tested! 12may93jaw
2:
3: \ May be cross-compiled
4:
5: decimal
6:
7: \ .( 12may93jaw
8:
9: : .( [char] ) parse type ;
10:
11: \ VALUE 2>R 2R> 2R@ 17may93jaw
12:
13: : value ( n -- ) (constant) , ;
14:
15: : 2>r postpone >r postpone >r ; immediate restrict
16: : 2r> postpone r> postpone r> ; immediate restrict
17: : 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate restrict
18:
19: : 2Literal swap postpone Literal postpone Literal ;
20: immediate restrict
21:
22: \ CASE OF ENDOF ENDCASE 17may93jaw
23:
24: \ just as described in dpANS5
25:
26: 0 CONSTANT case immediate
27:
28: : of
29: 1+ >r
30: postpone over postpone = postpone if postpone drop
31: r> ; immediate
32:
33: : endof
34: >r postpone else r> ; immediate
35:
36: : endcase
37: postpone drop
38: 0 ?do postpone then loop ; immediate
39:
40: \ C" 17may93jaw
41:
42: : (c") "lit ;
43:
44: : CLiteral postpone (c") here over char+ allot place align ;
45: immediate restrict
46: : C" [char] " parse postpone CLiteral ; immediate restrict
47:
48: \ UNUSED 17may93jaw
49:
50: : unused forthstart dup @ over 2 cells + @ -
51: 512 - \ for stack
52: + here - ;
53:
54: \ [COMPILE] 17may93jaw
55:
56: : [compile]
57: ' compile, ; immediate
58:
59: \ MARKER 17may93jaw
60:
61: \ : marker here last @ create , , DOES> dup @ last ! cell+ @ dp ! ;
62: \ doesn't work now. vocabularies?
63:
64: \ CONVERT 17may93jaw
65:
66: : convert true >number drop ;
67:
68: \ ERASE 17may93jaw
69:
70: : erase ( 0 1 chars um/mod nip ) 0 fill ;
71: : blank ( 0 1 chars um/mod nip ) bl fill ;
72:
73: \ ROLL 17may93jaw
74:
75: : roll dup 1+ pick >r
76: cells sp@ 2 cells + dup cell+ rot move drop r> ;
77:
78: \ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw
79:
80: : source-id ( -- 0 | -1 | fileid )
81: loadfile @ dup 0= IF drop linestart @ THEN ;
82:
83: : save-input ( -- x1 .. xn n )
84: >in @
85: loadfile @ ?dup
86: IF linestart 2@ loadline @ 6
87: ELSE loadline @ blk @ linestart @ 5 THEN
88: >tib @ swap ; \ >tib for security
89:
90: : restore-input ( x1 .. xn n -- flag )
91: 1- swap >tib @ <> IF discard true EXIT THEN
92: 5 = IF loadline ! 2dup linestart 2! rot dup loadfile !
93: reposition-file IF drop true EXIT THEN
94: refill 0= IF drop true EXIT THEN
95: ELSE linestart ! blk !
96: dup loadline @ <> IF 2drop true EXIT THEN
97: loadline !
98: THEN
99: >in ! false ;
100:
101:
102:
103: \ This things we don't need, but for being complete... jaw
104:
105: \ EXPECT SPAN 17may93jaw
106:
107: variable span
108:
109: : expect ( c-addr +len -- )
110: 0 rot over
111: BEGIN key decode >r 2over = r> or UNTIL
112: 2drop nip span ! ;
113:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>