[gforth] / gforth / extend.fs  

gforth: gforth/extend.fs

1 : anton 1.1 \ EXTEND.FS CORE-EXT Word not fully tested! 12may93jaw
2 :    
3 : anton 1.12 \ Copyright (C) 1995 Free Software Foundation, Inc.
4 :    
5 :     \ This file is part of Gforth.
6 :    
7 :     \ Gforth is free software; you can redistribute it and/or
8 :     \ modify it under the terms of the GNU General Public License
9 :     \ as published by the Free Software Foundation; either version 2
10 :     \ of the License, or (at your option) any later version.
11 :    
12 :     \ This program is distributed in the hope that it will be useful,
13 :     \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14 :     \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 :     \ GNU General Public License for more details.
16 :    
17 :     \ You should have received a copy of the GNU General Public License
18 :     \ along with this program; if not, write to the Free Software
19 :     \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20 :    
21 :    
22 : anton 1.1 \ May be cross-compiled
23 :    
24 :     decimal
25 :    
26 :     \ .( 12may93jaw
27 :    
28 : anton 1.11 : .( ( compilation "...<paren>" -- ) \ core-ext dot-paren
29 : anton 1.8 [char] ) parse type ; immediate
30 : anton 1.1
31 :     \ VALUE 2>R 2R> 2R@ 17may93jaw
32 :    
33 : anton 1.3 \ !! 2value
34 : anton 1.1
35 : anton 1.11 : 2Literal ( compilation w1 w2 -- ; run-time -- w1 w2 ) \ double two-literal
36 :     swap postpone Literal postpone Literal ; immediate restrict
37 : pazsan 1.2
38 : anton 1.16 ' drop alias d>s ( d -- n ) \ double d_to_s
39 :    
40 : anton 1.11 : m*/ ( d1 n2 u3 -- dqout ) \ double m-star-slash
41 :     >r s>d >r abs -rot
42 :     s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um*
43 :     swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap
44 :     r> IF dnegate THEN ;
45 : pazsan 1.4
46 : anton 1.1 \ CASE OF ENDOF ENDCASE 17may93jaw
47 :    
48 :     \ just as described in dpANS5
49 :    
50 : anton 1.11 0 CONSTANT case ( compilation -- case-sys ; run-time -- ) \ core-ext
51 :     immediate
52 : anton 1.1
53 : anton 1.11 : of ( compilation -- of-sys ; run-time x1 x2 -- |x1 ) \ core-ext
54 :     \ !! the implementation does not match the stack effect
55 :     1+ >r
56 :     postpone over postpone = postpone if postpone drop
57 :     r> ; immediate
58 :    
59 :     : endof ( compilation case-sys1 of-sys -- case-sys2 ; run-time -- ) \ core-ext end-of
60 :     >r postpone else r> ; immediate
61 :    
62 :     : endcase ( compilation case-sys -- ; run-time x -- ) \ core-ext end-case
63 :     postpone drop
64 :     0 ?do postpone then loop ; immediate
65 : anton 1.1
66 :     \ C" 17may93jaw
67 :    
68 :     : (c") "lit ;
69 :    
70 : anton 1.11 : CLiteral
71 :     postpone (c") here over char+ allot place align ; immediate restrict
72 :    
73 :     : C" ( compilation "...<quote>" -- ; run-time -- c-addr ) \ core-ext c-quote
74 :     [char] " parse postpone CLiteral ; immediate restrict
75 : anton 1.1
76 :     \ [COMPILE] 17may93jaw
77 :    
78 : anton 1.11 : [compile] ( compilation "name" -- ; run-time ? -- ? ) \ core-ext bracket-compile
79 : pazsan 1.24 comp' drop compile, ; immediate
80 : anton 1.1
81 :     \ MARKER 17may93jaw
82 :    
83 :     \ : marker here last @ create , , DOES> dup @ last ! cell+ @ dp ! ;
84 :     \ doesn't work now. vocabularies?
85 :    
86 :     \ CONVERT 17may93jaw
87 :    
88 : anton 1.11 : convert ( ud1 c-addr1 -- ud2 c-addr2 ) \ core-ext
89 : anton 1.26 \G obsolescent; superseded by @code{>number}.
90 :     char+ true >number drop ;
91 : anton 1.1
92 :     \ ERASE 17may93jaw
93 :    
94 : anton 1.11 : erase ( addr len -- ) \ core-ext
95 :     \ !! dependence on "1 chars 1 ="
96 :     ( 0 1 chars um/mod nip ) 0 fill ;
97 :     : blank ( addr len -- ) \ string
98 :     bl fill ;
99 : anton 1.1
100 : pazsan 1.7 \ SEARCH 02sep94py
101 :    
102 : anton 1.11 : search ( buf buflen text textlen -- restbuf restlen flag ) \ string
103 :     2over 2 pick - 1+ 3 pick c@ >r
104 :     BEGIN
105 :     r@ scan dup
106 :     WHILE
107 :     >r >r 2dup r@ -text
108 :     0=
109 :     IF
110 :     >r drop 2drop r> r> r> rot + 1- rdrop true
111 :     EXIT
112 :     THEN
113 :     r> r> 1 /string
114 :     REPEAT
115 :     2drop 2drop rdrop false ;
116 : pazsan 1.7
117 : anton 1.1 \ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw
118 :    
119 : anton 1.22 : source-id ( -- 0 | -1 | fileid ) \ core-ext,file source-i-d
120 : anton 1.13 loadfile @ dup 0= IF drop sourceline# 0 min THEN ;
121 : anton 1.1
122 : anton 1.11 : save-input ( -- x1 .. xn n ) \ core-ext
123 : anton 1.14 >in @
124 :     loadfile @
125 :     if
126 :     loadfile @ file-position throw
127 :     else
128 :     blk @
129 :     linestart @
130 :     then
131 :     sourceline#
132 :     >tib @
133 :     source-id
134 :     6 ;
135 : anton 1.1
136 : anton 1.11 : restore-input ( x1 .. xn n -- flag ) \ core-ext
137 : anton 1.14 6 <> -12 and throw
138 :     source-id <> -12 and throw
139 :     >tib !
140 :     >r ( line# )
141 :     loadfile @ 0<>
142 :     if
143 :     loadfile @ reposition-file throw
144 :     else
145 :     linestart !
146 :     blk !
147 :     sourceline# r@ <> blk @ 0= and loadfile @ 0= and
148 :     if
149 :     drop rdrop true EXIT
150 :     then
151 :     then
152 :     r> loadline !
153 :     >in !
154 :     false ;
155 :    
156 : anton 1.1 \ This things we don't need, but for being complete... jaw
157 :    
158 :     \ EXPECT SPAN 17may93jaw
159 :    
160 : anton 1.11 variable span ( -- a-addr ) \ core-ext
161 :     \ obsolescent
162 : anton 1.1
163 : anton 1.11 : expect ( c-addr +len -- ) \ core-ext
164 :     \ obsolescent; use accept
165 : anton 1.9 0 rot over
166 :     BEGIN ( maxlen span c-addr pos1 )
167 :     key decode ( maxlen span c-addr pos2 flag )
168 :     >r 2over = r> or
169 :     UNTIL
170 : pazsan 1.17 2 pick swap /string type
171 :     nip span ! ;
172 : anton 1.1
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help