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