Annotation of gforth/extend.fs, revision 1.4
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:
9: : .( [char] ) parse type ;
10:
11: \ VALUE 2>R 2R> 2R@ 17may93jaw
12:
1.3 anton 13: : value ( n -- )
14: (constant) , ;
15: \ !! 2value
1.1 anton 16:
1.4 ! pazsan 17: : 2>r postpone swap postpone >r postpone >r ; immediate restrict
! 18: : 2r> postpone r> postpone r> postpone swap ; immediate restrict
1.1 anton 19: : 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate restrict
20:
1.2 pazsan 21: : 2Literal swap postpone Literal postpone Literal ;
22: immediate restrict
23:
1.4 ! pazsan 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:
1.1 anton 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:
1.4 ! pazsan 57: : unused s0 @ 512 - \ for stack
! 58: here - ;
1.1 anton 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:
1.2 pazsan 76: : erase ( 0 1 chars um/mod nip ) 0 fill ;
77: : blank ( 0 1 chars um/mod nip ) bl fill ;
1.1 anton 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 )
1.4 ! pazsan 87: loadfile @ dup 0= IF drop loadline @ 0 min THEN ;
1.1 anton 88:
89: : save-input ( -- x1 .. xn n )
90: >in @
91: loadfile @ ?dup
1.4 ! pazsan 92: IF dup file-position throw loadline @ >tib @ 6
! 93: #tib @ >tib +!
! 94: ELSE loadline @ blk @ linestart @ >tib @ 5 THEN
! 95: ;
1.1 anton 96:
97: : restore-input ( x1 .. xn n -- flag )
1.4 ! pazsan 98: swap >tib !
! 99: 6 = IF loadline ! rot dup loadfile !
1.1 anton 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>