[gforth] / gforth / cross.fs  

gforth: gforth/cross.fs


1 : anton 1.1 \ CROSS.FS The Cross-Compiler 06oct92py
2 : pazsan 1.23 \ $Id: cross.fs,v 1.22 1995/02/06 18:14:30 anton Exp $
3 : anton 1.1 \ Idea and implementation: Bernd Paysan (py)
4 : pazsan 1.15 \ Copyright 1992-94 by the GNU Forth Development Group
5 : anton 1.1
6 :     \ Log:
7 :     \ changed in ; [ to state off 12may93jaw
8 :     \ included place +place 12may93jaw
9 :     \ for a created word (variable, constant...)
10 :     \ is now an alias in the target voabulary.
11 :     \ this means it is no longer necessary to
12 :     \ switch between vocabularies for variable
13 :     \ initialization 12may93jaw
14 :     \ discovered error in DOES>
15 :     \ replaced !does with (;code) 16may93jaw
16 :     \ made complete redesign and
17 :     \ introduced two vocs method
18 :     \ to be asure that the right words
19 :     \ are found 08jun93jaw
20 :     \ btw: ! works not with 16 bit
21 :     \ targets 09jun93jaw
22 :     \ added: 2user and value 11jun93jaw
23 :    
24 : pazsan 1.9 \ include other.fs \ ansforth extentions for cross
25 : anton 1.1
26 : pazsan 1.23 : string, ( c-addr u -- )
27 :     \ puts down string as cstring
28 :     dup c, here swap chars dup allot move ;
29 :     ' falign Alias cfalign
30 : pazsan 1.5 : comment? ( c-addr u -- c-addr u )
31 :     2dup s" (" compare 0=
32 :     IF postpone (
33 :     ELSE 2dup s" \" compare 0= IF postpone \ THEN
34 :     THEN ;
35 :    
36 : anton 1.1 decimal
37 :    
38 :     \ Begin CROSS COMPILER:
39 :    
40 :     \ GhostNames 9may93jaw
41 :     \ second name source to search trough list
42 :    
43 :     VARIABLE GhostNames
44 :     0 GhostNames !
45 :     : GhostName ( -- addr )
46 : anton 1.22 here GhostNames @ , GhostNames ! here 0 ,
47 :     bl word count
48 :     \ 2dup type space
49 :     string, cfalign ;
50 : anton 1.1
51 :     hex
52 :    
53 :    
54 :     Vocabulary Cross
55 :     Vocabulary Target
56 :     Vocabulary Ghosts
57 :     VOCABULARY Minimal
58 :     only Forth also Target also also
59 :     definitions Forth
60 :    
61 :     : T previous Cross also Target ; immediate
62 :     : G Ghosts ; immediate
63 :     : H previous Forth also Cross ; immediate
64 :    
65 :     forth definitions
66 :    
67 :     : T previous Cross also Target ; immediate
68 :     : G Ghosts ; immediate
69 :    
70 :     : >cross also Cross definitions previous ;
71 :     : >target also Target definitions previous ;
72 :     : >minimal also Minimal definitions previous ;
73 :    
74 :     H
75 :    
76 :     >CROSS
77 :    
78 :     \ Variables 06oct92py
79 :    
80 :     -1 Constant NIL
81 :     Variable image
82 :     Variable tlast NIL tlast ! \ Last name field
83 :     Variable tlastcfa \ Last code field
84 :     Variable tdoes \ Resolve does> calls
85 :     Variable bit$
86 :     Variable tdp
87 :     : there tdp @ ;
88 :    
89 :     \ Parameter for target systems 06oct92py
90 :    
91 : pazsan 1.13 included
92 : anton 1.1
93 : pazsan 1.19 \ Create additional parameters 19jan95py
94 :    
95 :     T
96 :     cell Constant tcell
97 :     cell<< Constant tcell<<
98 :     cell>bit Constant tcell>bit
99 :     bits/byte Constant tbits/byte
100 :     float Constant tfloat
101 :     1 bits/byte lshift Constant maxbyte
102 :     H
103 :    
104 : anton 1.1 >TARGET
105 :    
106 :     \ Byte ordering and cell size 06oct92py
107 :    
108 : pazsan 1.19 : cell+ tcell + ;
109 :     : cells tcell<< lshift ;
110 : anton 1.1 : chars ;
111 : pazsan 1.19 : floats tfloat * ;
112 : anton 1.6
113 : anton 1.1 >CROSS
114 : pazsan 1.19 : cell/ tcell<< rshift ;
115 : anton 1.1 >TARGET
116 :     20 CONSTANT bl
117 :     -1 Constant NIL
118 :     -2 Constant :docol
119 :     -3 Constant :docon
120 :     -4 Constant :dovar
121 : pazsan 1.3 -5 Constant :douser
122 : anton 1.10 -6 Constant :dodefer
123 : pazsan 1.24 -7 Constant :dostruc
124 :     -8 Constant :dodoes
125 :     -9 Constant :doesjump
126 : anton 1.1
127 :     >CROSS
128 :    
129 : pazsan 1.20 bigendian
130 :     [IF]
131 :     : T! ( n addr -- ) >r s>d r> tcell bounds swap 1-
132 :     DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
133 :     : T@ ( addr -- n ) >r 0 0 r> tcell bounds
134 :     DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
135 : pazsan 1.19 [ELSE]
136 : pazsan 1.20 : T! ( n addr -- ) >r s>d r> tcell bounds
137 :     DO maxbyte ud/mod rot I c! LOOP 2drop ;
138 :     : T@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1-
139 :     DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
140 : anton 1.1 [THEN]
141 :    
142 :     \ Memory initialisation 05dec92py
143 :     \ Fixed bug in else part 11may93jaw
144 :    
145 :     [IFDEF] Memory \ Memory is a bigFORTH feature
146 : pazsan 1.5 also Memory
147 : anton 1.1 : initmem ( var len -- )
148 :     2dup swap handle! >r @ r> erase ;
149 : pazsan 1.5 toss
150 : anton 1.1 [ELSE]
151 :     : initmem ( var len -- )
152 :     tuck allocate abort" CROSS: No memory for target"
153 :     ( len var adr ) dup rot !
154 :     ( len adr ) swap erase ;
155 :     [THEN]
156 :    
157 :     \ MakeKernal 12dec92py
158 :    
159 :     >MINIMAL
160 :     : makekernal ( targetsize -- targetsize )
161 :     bit$ over 1- cell>bit rshift 1+ initmem
162 :     image over initmem tdp off ;
163 :    
164 :     >CROSS
165 :     \ Bit string manipulation 06oct92py
166 :     \ 9may93jaw
167 :     CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
168 :     : bits ( n -- n ) chars Bittable + c@ ;
169 :    
170 :     : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
171 :     : +bit ( addr n -- ) >bit over c@ or swap c! ;
172 : pazsan 1.4 : -bit ( addr n -- ) >bit invert over c@ and swap c! ;
173 : anton 1.1 : relon ( taddr -- ) bit$ @ swap cell/ +bit ;
174 : pazsan 1.4 : reloff ( taddr -- ) bit$ @ swap cell/ -bit ;
175 : anton 1.1
176 :     \ Target memory access 06oct92py
177 :    
178 :     : align+ ( taddr -- rest )
179 :     cell tuck 1- and - [ cell 1- ] Literal and ;
180 : anton 1.22 : cfalign+ ( taddr -- rest )
181 :     \ see kernal.fs:cfaligned
182 :     float tuck 1- and - [ float 1- ] Literal and ;
183 : anton 1.1
184 :     >TARGET
185 :     : aligned ( taddr -- ta-addr ) dup align+ + ;
186 :     \ assumes cell alignment granularity (as GNU C)
187 :    
188 : anton 1.22 : cfaligned ( taddr1 -- taddr2 )
189 :     \ see kernal.fs
190 :     dup cfalign+ + ;
191 :    
192 : anton 1.1 >CROSS
193 :     : >image ( taddr -- absaddr ) image @ + ;
194 :     >TARGET
195 : pazsan 1.19 : @ ( taddr -- w ) >image t@ ;
196 :     : ! ( w taddr -- ) >image t! ;
197 : anton 1.1 : c@ ( taddr -- char ) >image c@ ;
198 :     : c! ( char taddr -- ) >image c! ;
199 : anton 1.7 : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
200 :     : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
201 : anton 1.1
202 :     \ Target compilation primitives 06oct92py
203 :     \ included A! 16may93jaw
204 :    
205 :     : here ( -- there ) there ;
206 :     : allot ( n -- ) tdp +! ;
207 :     : , ( w -- ) T here H cell T allot ! H ;
208 :     : c, ( char -- ) T here 1 allot c! H ;
209 :     : align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ;
210 : anton 1.22 : cfalign ( -- )
211 :     T here H cfalign+ 0 ?DO bl T c, H LOOP ;
212 : anton 1.1
213 :     : A! dup relon T ! H ;
214 :     : A, ( w -- ) T here H relon T , H ;
215 :    
216 :     >CROSS
217 :    
218 :     \ threading modell 13dec92py
219 :    
220 :     \ generic threading modell
221 :     : docol, ( -- ) :docol T A, 0 , H ;
222 :    
223 :     >TARGET
224 :     : >body ( cfa -- pfa ) T cell+ cell+ H ;
225 :     >CROSS
226 :    
227 : pazsan 1.3 : dodoes, ( -- ) T :doesjump A, 0 , H ;
228 : anton 1.1
229 :     \ Ghost Builder 06oct92py
230 :    
231 :     \ <T T> new version with temp variable 10may93jaw
232 :    
233 :     VARIABLE VocTemp
234 :    
235 :     : <T get-current VocTemp ! also Ghosts definitions ;
236 :     : T> previous VocTemp @ set-current ;
237 :    
238 :     4711 Constant <fwd> 4712 Constant <res>
239 :     4713 Constant <imm>
240 :    
241 :     \ iForth makes only immediate directly after create
242 :     \ make atonce trick! ?
243 :    
244 :     Variable atonce atonce off
245 :    
246 :     : NoExec true ABORT" CROSS: Don't execute ghost" ;
247 :    
248 :     : GhostHeader <fwd> , 0 , ['] NoExec , ;
249 :    
250 :     : >magic ; : >link cell+ ; : >exec cell+ cell+ ;
251 :     : >end 3 cells + ;
252 :    
253 : pazsan 1.11 Variable last-ghost
254 : anton 1.1 : Make-Ghost ( "name" -- ghost )
255 :     >in @ GhostName swap >in !
256 :     <T Create atonce @ IF immediate atonce off THEN
257 :     here tuck swap ! ghostheader T>
258 : pazsan 1.11 DOES> dup last-ghost ! >exec @ execute ;
259 : anton 1.1
260 :     \ ghost words 14oct92py
261 :     \ changed: 10may93py/jaw
262 :    
263 :     : gfind ( string -- ghost true/1 / string false )
264 :     \ searches for string in word-list ghosts
265 :     \ !! wouldn't it be simpler to just use search-wordlist ? ae
266 : pazsan 1.5 dup count [ ' ghosts >body ] ALiteral search-wordlist
267 : pazsan 1.13 dup IF >r >body nip r> THEN ;
268 : anton 1.1
269 :     VARIABLE Already
270 :    
271 :     : ghost ( "name" -- ghost )
272 :     Already off
273 : pazsan 1.13 >in @ bl word gfind IF Already on nip EXIT THEN
274 : anton 1.1 drop >in ! Make-Ghost ;
275 :    
276 :     \ resolve 14oct92py
277 :    
278 :     : resolve-loop ( ghost tcfa -- ghost tcfa )
279 :     >r dup >link @
280 :     BEGIN dup WHILE dup T @ H r@ rot T ! H REPEAT drop r> ;
281 :    
282 :     \ exists 9may93jaw
283 :    
284 :     : exists ( ghost tcfa -- )
285 :     over GhostNames
286 :     BEGIN @ dup
287 :     WHILE 2dup cell+ @ =
288 :     UNTIL
289 : pazsan 1.18 2 cells + count cr ." CROSS: Exists: " type 4 spaces drop
290 : anton 1.1 swap cell+ !
291 : pazsan 1.24 ELSE true abort" CROSS: Ghostnames inconsistent "
292 : anton 1.1 THEN ;
293 :    
294 :     : resolve ( ghost tcfa -- )
295 :     over >magic @ <fwd> <> IF exists EXIT THEN
296 :     resolve-loop over >link ! <res> swap >magic ! ;
297 :    
298 :     \ gexecute ghost, 01nov92py
299 :    
300 :     : do-forward ( ghost -- )
301 :     >link dup @ there rot ! T A, H ;
302 :     : do-resolve ( ghost -- )
303 :     >link @ T A, H ;
304 :    
305 :     : gexecute ( ghost -- ) dup @
306 :     <fwd> = IF do-forward ELSE do-resolve THEN ;
307 :     : ghost, ghost gexecute ;
308 :    
309 :     \ .unresolved 11may93jaw
310 :    
311 :     variable ResolveFlag
312 :    
313 :     \ ?touched 11may93jaw
314 :    
315 :     : ?touched ( ghost -- flag ) dup >magic @ <fwd> = swap >link @
316 :     0 <> and ;
317 :    
318 :     : ?resolved ( ghostname -- )
319 :     dup cell+ @ ?touched
320 :     IF cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;
321 :    
322 :     >MINIMAL
323 :     : .unresolved ( -- )
324 :     ResolveFlag off cr ." Unresolved: "
325 :     Ghostnames
326 :     BEGIN @ dup
327 :     WHILE dup ?resolved
328 : anton 1.10 REPEAT drop ResolveFlag @
329 :     IF
330 : pazsan 1.11 abort" Unresolved words!"
331 : anton 1.10 ELSE
332 :     ." Nothing!"
333 :     THEN
334 :     cr ;
335 : anton 1.1
336 :     >CROSS
337 :     \ Header states 12dec92py
338 :    
339 :     : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ;
340 :    
341 :     VARIABLE ^imm
342 :    
343 :     >TARGET
344 :     : immediate 20 flag!
345 : pazsan 1.18 ^imm @ @ dup <imm> = IF drop EXIT THEN
346 : anton 1.1 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
347 :     <imm> ^imm @ ! ;
348 : pazsan 1.8 : restrict 40 flag! ;
349 : anton 1.1 >CROSS
350 :    
351 :     \ ALIAS2 ansforth conform alias 9may93jaw
352 :    
353 :     : ALIAS2 create here 0 , DOES> @ execute ;
354 :     \ usage:
355 : pazsan 1.18 \ ' <name> alias2 bla !
356 : anton 1.1
357 :     \ Target Header Creation 01nov92py
358 :    
359 :     : string, ( addr count -- )
360 : pazsan 1.28 dup T c, H bounds ?DO I c@ T c, H LOOP ;
361 : anton 1.22 : name, ( "name" -- ) bl word count string, T cfalign H ;
362 : anton 1.1 : view, ( -- ) ( dummy ) ;
363 :    
364 : pazsan 1.25 \ Target Document Creation (goes to crossdoc.fd) 05jul95py
365 :    
366 :     s" crossdoc.fd" r/w create-file throw value doc-file-id
367 :     \ contains the file-id of the documentation file
368 :    
369 :     : \G ( -- )
370 :     source >in @ /string doc-file-id write-line throw
371 :     source >in ! drop ; immediate
372 :    
373 :     Variable to-doc
374 :    
375 :     : cross-doc-entry ( -- )
376 :     to-doc @ tlast @ 0<> and \ not an anonymous (i.e. noname) header
377 :     IF
378 :     s" " doc-file-id write-line throw
379 :     s" make-doc " doc-file-id write-file throw
380 :     tlast @ >image count $1F and doc-file-id write-file throw
381 :     >in @
382 :     [char] ( parse 2drop
383 :     [char] ) parse doc-file-id write-file throw
384 :     s" )" doc-file-id write-file throw
385 :     [char] \ parse 2drop
386 :     POSTPONE \g
387 :     >in !
388 :     THEN to-doc on ;
389 :    
390 : pazsan 1.28 \ Target TAGS creation
391 :    
392 :     s" TAGS" r/w create-file throw value tag-file-id
393 :     \ contains the file-id of the tags file
394 :    
395 :     Create tag-beg 2 c, 7F c, bl c,
396 :     Create tag-end 2 c, bl c, 01 c,
397 :     Create tag-bof 1 c, 0C c,
398 :    
399 :     2variable last-loadfilename 0 0 last-loadfilename 2!
400 :    
401 :     : put-load-file-name ( -- )
402 :     loadfilename 2@ last-loadfilename 2@ d<>
403 :     IF
404 :     tag-bof count tag-file-id write-line throw
405 :     loadfilename 2@ 2dup
406 :     tag-file-id write-file throw
407 :     last-loadfilename 2!
408 :     s" ,0" tag-file-id write-line throw
409 :     THEN ;
410 :    
411 :     : cross-tag-entry ( -- )
412 :     tlast @ 0<> \ not an anonymous (i.e. noname) header
413 :     IF
414 :     put-load-file-name
415 :     source >in @ min tag-file-id write-file throw
416 :     tag-beg count tag-file-id write-file throw
417 :     tlast @ >image count $1F and tag-file-id write-file throw
418 :     tag-end count tag-file-id write-file throw
419 :     base @ decimal loadline @ 0 <# #s #> tag-file-id write-file throw
420 :     \ >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
421 :     s" ,0" tag-file-id write-line throw
422 :     base !
423 :     THEN ;
424 :    
425 :     \ Target header creation
426 :    
427 : anton 1.1 VARIABLE CreateFlag CreateFlag off
428 :    
429 :     : (Theader ( "name" -- ghost ) T align H view,
430 :     tlast @ dup 0> IF T 1 cells - THEN A, H there tlast !
431 :     >in @ name, >in ! T here H tlastcfa !
432 :     CreateFlag @ IF
433 : pazsan 1.18 >in @ alias2 swap >in ! \ create alias in target
434 :     >in @ ghost swap >in !
435 :     swap also ghosts ' previous swap ! \ tick ghost and store in alias
436 :     CreateFlag off
437 : anton 1.1 ELSE ghost THEN
438 :     dup >magic ^imm ! \ a pointer for immediate
439 :     Already @ IF dup >end tdoes !
440 :     ELSE 0 tdoes ! THEN
441 : pazsan 1.25 80 flag!
442 : pazsan 1.28 cross-doc-entry cross-tag-entry ;
443 : anton 1.1
444 :     VARIABLE ;Resolve 1 cells allot
445 :    
446 : pazsan 1.11 : Theader ( "name" -- ghost )
447 :     (THeader dup there resolve 0 ;Resolve ! ;
448 : anton 1.1
449 :     >TARGET
450 :     : Alias ( cfa -- ) \ name
451 : pazsan 1.25 dup 0< IF to-doc off THEN
452 : anton 1.1 (THeader over resolve T A, H 80 flag! ;
453 :     >CROSS
454 :    
455 :     \ Conditionals and Comments 11may93jaw
456 :    
457 :     : ;Cond
458 :     postpone ;
459 :     swap ! ; immediate
460 :    
461 :     : Cond: ( -- ) \ name {code } ;
462 :     atonce on
463 :     ghost
464 :     >exec
465 :     :NONAME ;
466 :    
467 :     : restrict? ( -- )
468 :     \ aborts on interprete state - ae
469 :     state @ 0= ABORT" CROSS: Restricted" ;
470 :    
471 :     : Comment ( -- )
472 :     >in @ atonce on ghost swap >in ! ' swap >exec ! ;
473 :    
474 :     Comment ( Comment \
475 :    
476 :     \ Predefined ghosts 12dec92py
477 :    
478 :     ghost 0= drop
479 :     ghost branch ghost ?branch 2drop
480 :     ghost (do) ghost (?do) 2drop
481 :     ghost (for) drop
482 :     ghost (loop) ghost (+loop) 2drop
483 :     ghost (next) drop
484 : pazsan 1.2 ghost unloop ghost ;S 2drop
485 : anton 1.1 ghost lit ghost (compile) ghost ! 2drop drop
486 :     ghost (;code) ghost noop 2drop
487 :     ghost (.") ghost (S") ghost (ABORT") 2drop drop
488 : pazsan 1.9 ghost '
489 : anton 1.1
490 :     \ compile 10may93jaw
491 :    
492 :     : compile ( -- ) \ name
493 :     restrict?
494 : pazsan 1.13 bl word gfind dup 0= ABORT" CROSS: Can't compile "
495 : anton 1.1 0> ( immediate? )
496 :     IF >exec @ compile,
497 :     ELSE postpone literal postpone gexecute THEN ;
498 :     immediate
499 :    
500 :     >TARGET
501 : pazsan 1.13 : ' ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "
502 : anton 1.1 dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;
503 :    
504 :     Cond: ['] compile lit ghost gexecute ;Cond
505 : anton 1.14
506 :     Cond: chars ;Cond
507 : anton 1.1
508 :     >CROSS
509 :     \ tLiteral 12dec92py
510 :    
511 :     : lit, ( n -- ) compile lit T , H ;
512 :     : alit, ( n -- ) compile lit T A, H ;
513 :    
514 :     >TARGET
515 :     Cond: Literal ( n -- ) restrict? lit, ;Cond
516 :     Cond: ALiteral ( n -- ) restrict? alit, ;Cond
517 :    
518 :     : Char ( "<char>" -- ) bl word char+ c@ ;
519 :     Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond
520 :    
521 :     >CROSS
522 :     \ Target compiling loop 12dec92py
523 :     \ ">tib trick thrown out 10may93jaw
524 :     \ number? defined at the top 11may93jaw
525 :    
526 :     \ compiled word might leave items on stack!
527 :     : tcom ( in name -- )
528 :     gfind ?dup IF 0> IF nip >exec @ execute
529 :     ELSE nip gexecute THEN EXIT THEN
530 :     number? dup IF 0> IF swap lit, THEN lit, drop
531 :     ELSE 2drop >in !
532 :     ghost gexecute THEN ;
533 :    
534 :     >TARGET
535 :     \ : ; DOES> 13dec92py
536 :     \ ] 9may93py/jaw
537 :    
538 :     : ] state on
539 :     BEGIN
540 : pazsan 1.13 BEGIN >in @ bl word
541 : anton 1.1 dup c@ 0= WHILE 2drop refill 0=
542 :     ABORT" CROSS: End of file while target compiling"
543 :     REPEAT
544 :     tcom
545 :     state @
546 :     0=
547 :     UNTIL ;
548 :    
549 :     \ by the way: defining a second interpreter (a compiler-)loop
550 :     \ is not allowed if a system should be ans conform
551 :    
552 :     : : ( -- colon-sys ) \ Name
553 :     (THeader ;Resolve ! there ;Resolve cell+ !
554 :     docol, depth T ] H ;
555 :    
556 : pazsan 1.2 Cond: EXIT ( -- ) restrict? compile ;S ;Cond
557 : anton 1.6
558 :     Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
559 : pazsan 1.2
560 : anton 1.1 Cond: ; ( -- ) restrict?
561 :     depth ?dup IF 1- <> ABORT" CROSS: Stack changed"
562 :     ELSE true ABORT" CROSS: Stack empty" THEN
563 : pazsan 1.2 compile ;S state off
564 : anton 1.1 ;Resolve @
565 :     IF ;Resolve @ ;Resolve cell+ @ resolve THEN
566 :     ;Cond
567 :     Cond: [ restrict? state off ;Cond
568 :    
569 :     >CROSS
570 :     : !does :dodoes tlastcfa @ tuck T ! cell+ ! H ;
571 :    
572 :     >TARGET
573 :     Cond: DOES> restrict?
574 :     compile (;code) dodoes, tdoes @ ?dup IF @ T here H resolve THEN
575 :     ;Cond
576 :     : DOES> dodoes, T here H !does depth T ] H ;
577 :    
578 :     >CROSS
579 :     \ Creation 01nov92py
580 :    
581 :     \ Builder 11may93jaw
582 :    
583 :     : Builder ( Create do: "name" -- )
584 :     >in @ alias2 swap dup >in ! >r >r
585 :     Make-Ghost rot swap >exec ! ,
586 :     r> r> >in !
587 : pazsan 1.11 also ghosts ' previous swap ! ;
588 :     \ DOES> dup >exec @ execute ;
589 : anton 1.1
590 :     : gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <>
591 :     IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN
592 : pazsan 1.4 :dodoes T A, H gexecute T here H cell - reloff ;
593 : anton 1.1
594 : pazsan 1.11 : TCreate ( -- )
595 :     last-ghost @
596 : anton 1.1 CreateFlag on
597 : pazsan 1.11 Theader >r dup gdoes,
598 :     >end @ >exec @ r> >exec ! ;
599 : anton 1.1
600 :     : Build: ( -- [xt] [colon-sys] )
601 :     :noname postpone TCreate ;
602 :    
603 :     : gdoes> ( ghost -- addr flag )
604 : pazsan 1.11 last-ghost @
605 : anton 1.1 state @ IF gexecute true EXIT THEN
606 :     cell+ @ T >body H false ;
607 :    
608 :     \ DO: ;DO 11may93jaw
609 :     \ changed to ?EXIT 10may93jaw
610 :    
611 :     : DO: ( -- addr [xt] [colon-sys] )
612 :     here ghostheader
613 : pazsan 1.11 :noname postpone gdoes> postpone ?EXIT ;
614 : anton 1.1
615 :     : ;DO ( addr [xt] [colon-sys] -- )
616 :     postpone ; ( S addr xt )
617 :     over >exec ! ; immediate
618 :    
619 :     : by ( -- addr ) \ Name
620 :     ghost >end @ ;
621 :    
622 :     >TARGET
623 :     \ Variables and Constants 05dec92py
624 :    
625 :     Build: ;
626 :     DO: ( ghost -- addr ) ;DO
627 :     Builder Create
628 :     by Create :dovar resolve
629 :    
630 :     Build: T 0 , H ;
631 :     by Create
632 :     Builder Variable
633 :    
634 :     Build: T 0 A, H ;
635 :     by Create
636 :     Builder AVariable
637 :    
638 : pazsan 1.3 \ User variables 04may94py
639 :    
640 :     >CROSS
641 :     Variable tup 0 tup !
642 :     Variable tudp 0 tudp !
643 :     : u, ( n -- udp )
644 :     tup @ tudp @ + T ! H
645 : pazsan 1.19 tudp @ dup T cell+ H tudp ! ;
646 : pazsan 1.3 : au, ( n -- udp )
647 :     tup @ tudp @ + T A! H
648 : pazsan 1.19 tudp @ dup T cell+ H tudp ! ;
649 : pazsan 1.3 >TARGET
650 :    
651 :     Build: T 0 u, , H ;
652 :     DO: ( ghost -- up-addr ) T @ H tup @ + ;DO
653 : anton 1.1 Builder User
654 : pazsan 1.3 by User :douser resolve
655 : anton 1.1
656 : pazsan 1.3 Build: T 0 u, , 0 u, drop H ;
657 :     by User
658 : anton 1.1 Builder 2User
659 :    
660 : pazsan 1.3 Build: T 0 au, , H ;
661 :     by User
662 : anton 1.1 Builder AUser
663 :    
664 :     Build: ( n -- ) T , H ;
665 :     DO: ( ghost -- n ) T @ H ;DO
666 :     Builder Constant
667 :     by Constant :docon resolve
668 :    
669 :     Build: ( n -- ) T A, H ;
670 :     by Constant
671 :     Builder AConstant
672 :    
673 : pazsan 1.24 Build: ( d -- ) T , , H ;
674 :     DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
675 :     Builder 2Constant
676 :    
677 : anton 1.1 Build: T 0 , H ;
678 :     by Constant
679 :     Builder Value
680 :    
681 :     Build: ( -- ) compile noop ;
682 :     DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
683 :     Builder Defer
684 : anton 1.10 by Defer :dodefer resolve
685 : pazsan 1.24
686 :     \ Sturctures 23feb95py
687 :    
688 :     >CROSS
689 :     : nalign ( addr1 n -- addr2 )
690 :     \ addr2 is the aligned version of addr1 wrt the alignment size n
691 :     1- tuck + swap invert and ;
692 :     >TARGET
693 :    
694 :     Build: >r rot r@ nalign dup T , H ( align1 size offset )
695 :     + swap r> nalign ;
696 :     DO: T @ H + ;DO
697 :     Builder Field
698 :     by Field :dostruc resolve
699 :    
700 :     : struct T 0 1 chars H ;
701 :     : end-struct T 2Constant H ;
702 :    
703 :     : cells: ( n -- size align )
704 :     T cells 1 cells H ;
705 :    
706 :     \ ' 2Constant Alias2 end-struct
707 :     \ 0 1 T Chars H 2Constant struct
708 : anton 1.1
709 :     \ structural conditionals 17dec92py
710 :    
711 :     >CROSS
712 :     : ?struc ( flag -- ) ABORT" CROSS: unstructured " ;
713 :     : sys? ( sys -- sys ) dup 0= ?struc ;
714 :     : >mark ( -- sys ) T here 0 , H ;
715 :     : >resolve ( sys -- ) T here over - swap ! H ;
716 :     : <resolve ( sys -- ) T here - , H ;
717 :     >TARGET
718 :    
719 :     \ Structural Conditionals 12dec92py
720 :    
721 :     Cond: BUT restrict? sys? swap ;Cond
722 :     Cond: YET restrict? sys? dup ;Cond
723 :    
724 :     >CROSS
725 :     Variable tleavings
726 :     >TARGET
727 :    
728 :     Cond: DONE ( addr -- ) restrict? tleavings @
729 :     BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT
730 :     tleavings ! drop ;Cond
731 :    
732 :     >CROSS
733 :     : (leave T here H tleavings @ T , H tleavings ! ;
734 :     >TARGET
735 :    
736 :     Cond: LEAVE restrict? compile branch (leave ;Cond
737 :     Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond
738 :    
739 :     \ Structural Conditionals 12dec92py
740 :    
741 :     Cond: AHEAD restrict? compile branch >mark ;Cond
742 :     Cond: IF restrict? compile ?branch >mark ;Cond
743 :     Cond: THEN restrict? sys? dup T @ H ?struc >resolve ;Cond
744 :     Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond
745 :    
746 :     Cond: BEGIN restrict? T here H ;Cond
747 :     Cond: WHILE restrict? sys? compile IF swap ;Cond
748 :     Cond: AGAIN restrict? sys? compile branch <resolve ;Cond
749 :     Cond: UNTIL restrict? sys? compile ?branch <resolve ;Cond
750 :     Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond
751 :    
752 :     \ Structural Conditionals 12dec92py
753 :    
754 :     Cond: DO restrict? compile (do) T here H ;Cond
755 :     Cond: ?DO restrict? compile (?do) (leave T here H ;Cond
756 :     Cond: FOR restrict? compile (for) T here H ;Cond
757 :    
758 :     >CROSS
759 :     : loop] dup <resolve cell - compile DONE compile unloop ;
760 :     >TARGET
761 :    
762 :     Cond: LOOP restrict? sys? compile (loop) loop] ;Cond
763 :     Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond
764 :     Cond: NEXT restrict? sys? compile (next) loop] ;Cond
765 :    
766 :     \ String words 23feb93py
767 :    
768 :     : ," [char] " parse string, T align H ;
769 :    
770 :     Cond: ." restrict? compile (.") T ," H ;Cond
771 :     Cond: S" restrict? compile (S") T ," H ;Cond
772 :     Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond
773 :    
774 :     Cond: IS T ' >body H compile ALiteral compile ! ;Cond
775 :     : IS T ' >body ! H ;
776 : pazsan 1.9 Cond: TO T ' >body H compile ALiteral compile ! ;Cond
777 :     : TO T ' >body ! H ;
778 : anton 1.1
779 :     \ LINKED ERR" ENV" 2ENV" 18may93jaw
780 :    
781 :     \ linked list primitive
782 :     : linked T here over @ A, swap ! H ;
783 :    
784 :     : err" s" ErrLink linked" evaluate T , H
785 :     [char] " parse string, T align H ;
786 :    
787 :     : env" [char] " parse s" EnvLink linked" evaluate
788 :     string, T align , H ;
789 :    
790 :     : 2env" [char] " parse s" EnvLink linked" evaluate
791 :     here >r string, T align , , H
792 :     r> dup T c@ H 80 and swap T c! H ;
793 :    
794 :     \ compile must be last 22feb93py
795 :    
796 :     Cond: compile ( -- ) restrict? \ name
797 : pazsan 1.13 bl word gfind dup 0= ABORT" CROSS: Can't compile"
798 : anton 1.1 0> IF gexecute
799 :     ELSE dup >magic @ <imm> =
800 :     IF gexecute
801 :     ELSE compile (compile) gexecute THEN THEN ;Cond
802 :    
803 :     Cond: postpone ( -- ) restrict? \ name
804 : pazsan 1.13 bl word gfind dup 0= ABORT" CROSS: Can't compile"
805 : anton 1.1 0> IF gexecute
806 :     ELSE dup >magic @ <imm> =
807 :     IF gexecute
808 :     ELSE compile (compile) gexecute THEN THEN ;Cond
809 :    
810 :     >MINIMAL
811 :     also minimal
812 :     \ Usefull words 13feb93py
813 :    
814 :     : KB 400 * ;
815 :    
816 :     \ define new [IFDEF] and [IFUNDEF] 20may93jaw
817 :    
818 : pazsan 1.13 : there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ;
819 : anton 1.1
820 :     : [IFDEF] there? postpone [IF] ;
821 :     : [IFUNDEF] there? 0= postpone [IF] ;
822 :    
823 :     \ C: \- \+ Conditional Compiling 09jun93jaw
824 :    
825 :     : C: >in @ there? 0=
826 :     IF >in ! T : H
827 :     ELSE drop
828 :     BEGIN bl word dup c@
829 :     IF count comment? s" ;" compare 0= ?EXIT
830 :     ELSE refill 0= ABORT" CROSS: Out of Input while C:"
831 :     THEN
832 :     AGAIN
833 :     THEN ;
834 :    
835 :     also minimal
836 :    
837 :     : \- there? IF postpone \ THEN ;
838 :     : \+ there? 0= IF postpone \ THEN ;
839 :    
840 :     : [IF] postpone [IF] ;
841 :     : [THEN] postpone [THEN] ;
842 :     : [ELSE] postpone [ELSE] ;
843 :    
844 :     Cond: [IF] [IF] ;Cond
845 :     Cond: [IFDEF] [IFDEF] ;Cond
846 :     Cond: [IFUNDEF] [IFUNDEF] ;Cond
847 :     Cond: [THEN] [THEN] ;Cond
848 :     Cond: [ELSE] [ELSE] ;Cond
849 :    
850 :     \ save-cross 17mar93py
851 :    
852 :     \ i'm not interested in bigforth features this time 10may93jaw
853 :     \ [IFDEF] file
854 :     \ also file
855 :     \ [THEN]
856 :     \ included throw after create-file 11may93jaw
857 :    
858 : anton 1.12 bigendian Constant bigendian
859 : anton 1.1
860 : pazsan 1.26 Create magic s" gforth00" here over allot swap move
861 :    
862 :     [char] 1 bigendian + cell + magic 7 + c!
863 :    
864 : anton 1.1 : save-cross ( "name" -- )
865 :     bl parse ." Saving to " 2dup type
866 :     w/o bin create-file throw >r
867 : pazsan 1.26 magic 8 r@ write-file throw \ write magic
868 : pazsan 1.16 image @ there r@ write-file throw \ write image
869 :     bit$ @ there 1- cell>bit rshift 1+
870 :     r@ write-file throw \ write tags
871 : anton 1.1 r> close-file throw ;
872 :    
873 :     \ words that should be in minimal
874 :    
875 :     : + + ; : 1- 1- ;
876 :     : - - ; : 2* 2* ;
877 : pazsan 1.11 : * * ; : / / ;
878 : anton 1.1 : dup dup ; : over over ;
879 :     : swap swap ; : rot rot ;
880 : pazsan 1.19 : drop drop ; : = = ;
881 : pazsan 1.13 : lshift lshift ; : 2/ 2/ ;
882 : pazsan 1.19 : . . ;
883 : pazsan 1.13 cell constant cell
884 : anton 1.1
885 :     \ include bug5.fs
886 :     \ only forth also minimal definitions
887 :    
888 : pazsan 1.25 : \ postpone \ ;
889 :     : \G postpone \G ;
890 :     : ( postpone ( ;
891 : anton 1.1 : include bl word count included ;
892 :     : .( [char] ) parse type ;
893 :     : cr cr ;
894 :    
895 :     : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation
896 :     only forth also minimal definitions
897 :    
898 :     \ cross-compiler words
899 :    
900 :     : decimal decimal ;
901 :     : hex hex ;
902 :    
903 : pazsan 1.3 : tudp T tudp H ;
904 :     : tup T tup H ; minimal
905 : anton 1.1
906 :     \ for debugging...
907 :     : order order ;
908 :     : words words ;
909 :     : .s .s ;
910 :    
911 :     : bye bye ;
912 :    
913 :     \ turnkey direction
914 :     : H forth ; immediate
915 :     : T minimal ; immediate
916 :     : G ghosts ; immediate
917 :    
918 :     : turnkey 0 set-order also Target definitions
919 :     also Minimal also ;
920 :    
921 :     \ these ones are pefered:
922 :    
923 :     : lock turnkey ;
924 :     : unlock forth also cross ;
925 :    
926 :     unlock definitions also minimal
927 :     : lock lock ;
928 :     lock

CVS Admin

Powered by ViewCVS 1.0-dev
(Powered by ViewCVS)

ViewCVS and CVS Help