Annotation of gforth/extend.fs, revision 1.10
1.1 anton 1: \ EXTEND.FS CORE-EXT Word not fully tested! 12may93jaw
2:
3: \ May be cross-compiled
4:
5: decimal
6:
7: \ .( 12may93jaw
8:
1.8 anton 9: : .( ( -- )
10: [char] ) parse type ; immediate
1.1 anton 11:
12: \ VALUE 2>R 2R> 2R@ 17may93jaw
13:
1.3 anton 14: : value ( n -- )
15: (constant) , ;
16: \ !! 2value
1.1 anton 17:
1.2 pazsan 18: : 2Literal swap postpone Literal postpone Literal ;
19: immediate restrict
20:
1.4 pazsan 21: : 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:
1.1 anton 26: \ 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:
1.4 pazsan 54: : unused s0 @ 512 - \ for stack
55: here - ;
1.1 anton 56:
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:
1.10 ! pazsan 73: : erase ( addr len -- ) ( 0 1 chars um/mod nip ) 0 fill ;
! 74: : blank ( addr len -- ) ( 0 1 chars um/mod nip ) bl fill ;
1.1 anton 75:
1.7 pazsan 76: \ 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:
1.1 anton 86: \ ROLL 17may93jaw
87:
1.10 ! pazsan 88: : roll ( x0 x1 .. xn n -- x1 .. xn x0 )
! 89: dup 1+ pick >r
! 90: cells sp@ cell+ dup cell+ rot move drop r> ;
1.1 anton 91:
92: \ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw
93:
94: : source-id ( -- 0 | -1 | fileid )
1.4 pazsan 95: loadfile @ dup 0= IF drop loadline @ 0 min THEN ;
1.1 anton 96:
97: : save-input ( -- x1 .. xn n )
98: >in @
99: loadfile @ ?dup
1.4 pazsan 100: IF dup file-position throw loadline @ >tib @ 6
101: #tib @ >tib +!
102: ELSE loadline @ blk @ linestart @ >tib @ 5 THEN
103: ;
1.1 anton 104:
105: : restore-input ( x1 .. xn n -- flag )
1.4 pazsan 106: swap >tib !
107: 6 = IF loadline ! rot dup loadfile !
1.1 anton 108: reposition-file IF drop true EXIT THEN
109: ELSE linestart ! blk !
110: dup loadline @ <> IF 2drop true EXIT THEN
111: loadline !
112: THEN
113: >in ! false ;
114:
115:
116:
117: \ This things we don't need, but for being complete... jaw
118:
119: \ EXPECT SPAN 17may93jaw
120:
121: variable span
122:
123: : expect ( c-addr +len -- )
1.9 anton 124: 0 rot over
125: BEGIN ( maxlen span c-addr pos1 )
126: key decode ( maxlen span c-addr pos2 flag )
127: >r 2over = r> or
128: UNTIL
129: type-rest drop
130: 2drop nip span ! ;
1.1 anton 131:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>