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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help