[gforth] / gforth / extend.fs  

gforth: gforth/extend.fs

1 : anton 1.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 : anton 1.3 : value ( n -- )
14 :     (constant) , ;
15 :     \ !! 2value
16 : anton 1.1
17 : pazsan 1.4 : 2>r postpone swap postpone >r postpone >r ; immediate restrict
18 :     : 2r> postpone r> postpone r> postpone swap ; immediate restrict
19 : anton 1.1 : 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate restrict
20 :    
21 : pazsan 1.2 : 2Literal swap postpone Literal postpone Literal ;
22 :     immediate restrict
23 :    
24 : pazsan 1.4 : 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 : anton 1.1 \ 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 : pazsan 1.4 : unused s0 @ 512 - \ for stack
58 :     here - ;
59 : anton 1.1
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 : pazsan 1.2 : erase ( 0 1 chars um/mod nip ) 0 fill ;
77 :     : blank ( 0 1 chars um/mod nip ) bl fill ;
78 : anton 1.1
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 : pazsan 1.4 loadfile @ dup 0= IF drop loadline @ 0 min THEN ;
88 : anton 1.1
89 :     : save-input ( -- x1 .. xn n )
90 :     >in @
91 :     loadfile @ ?dup
92 : pazsan 1.4 IF dup file-position throw loadline @ >tib @ 6
93 :     #tib @ >tib +!
94 :     ELSE loadline @ blk @ linestart @ >tib @ 5 THEN
95 :     ;
96 : anton 1.1
97 :     : restore-input ( x1 .. xn n -- flag )
98 : pazsan 1.4 swap >tib !
99 :     6 = IF loadline ! rot dup loadfile !
100 : anton 1.1 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 :    
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help