File:
[gforth] /
gforth /
prims2x.fs
Revision
1.24:
download - view:
text,
annotated -
select for diffs
Wed Aug 21 14:58:43 1996 UTC (27 years, 8 months ago) by
anton
Branches:
MAIN
CVS tags:
v0-2-1,
v0-2-0,
HEAD
a little cleanup in 386.h
renamed special: to interpret/compile:
renamed save-string to save-mem
added extend-mem
replaced (name>) with ((name>))
replaced name> with name>int and name>comp
renamed compile-only to compile-only-error
replaced xt>i with name>int
replaced xt>c with name>comp
removed xt>s
removed found
search-wordlist now delivers interpretation-xt
replaced (sfind) with find-name
replaced C' with COMP' and [C'] with [COMP']
removed S' and [S']
added hex.
added some helper words
adapted other words to the changes
started documenting the intergration of Gforth in applications
1: \ converts primitives to, e.g., C code
2:
3: \ 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: \ This is not very nice (hard limits, no checking, assumes 1 chars = 1)
23:
24: \ Optimizations:
25: \ superfluous stores are removed. GCC removes the superfluous loads by itself
26: \ TOS and FTOS can be kept in register( variable)s.
27: \
28: \ Problems:
29: \ The TOS optimization is somewhat hairy. The problems by example:
30: \ 1) dup ( w -- w w ): w=TOS; sp-=1; sp[1]=w; TOS=w;
31: \ The store is not superfluous although the earlier opt. would think so
32: \ Alternatively: sp[0]=TOS; w=TOS; sp-=1; TOS=w;
33: \ 2) ( -- .. ): sp[0] = TOS; ... /* This additional store is necessary */
34: \ 3) ( .. -- ): ... TOS = sp[0]; /* as well as this load */
35: \ 4) ( -- ): /* but here they are unnecessary */
36: \ 5) Words that call NEXT themselves have to be done very carefully.
37: \
38: \ To do:
39: \ add the store optimization for doubles
40: \ regarding problem 1 above: It would be better (for over) to implement
41: \ the alternative
42:
43: warnings off
44:
45: \ require interpretation.fs
46: require debugging.fs
47: [IFUNDEF] vocabulary include search-order.fs [THEN]
48: [IFUNDEF] environment? include environ.fs [THEN]
49: include gray.fs
50:
51: 100 constant max-effect \ number of things on one side of a stack effect
52: 255 constant maxchar
53: maxchar 1+ constant eof-char
54: #tab constant tab-char
55: #lf constant nl-char
56:
57: : read-whole-file ( c-addr1 file-id -- c-addr2 )
58: \ reads the contents of the file file-id puts it into memory at c-addr1
59: \ c-addr2 is the first address after the file block
60: >r dup $7fffffff r> read-file throw + ;
61:
62: variable rawinput \ pointer to next character to be scanned
63: variable endrawinput \ pointer to the end of the input (the char after the last)
64: variable cookedinput \ pointer to the next char to be parsed
65: variable line \ line number of char pointed to by input
66: 1 line !
67: 2variable filename \ filename of original input file
68: 0 0 filename 2!
69: variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?
70: skipsynclines on
71:
72: : start ( -- addr )
73: cookedinput @ ;
74:
75: : end ( addr -- addr u )
76: cookedinput @ over - ;
77:
78: variable output \ xt ( -- ) of output word
79:
80: : printprim ( -- )
81: output @ execute ;
82:
83: : field
84: <builds-field ( n1 n2 -- n3 )
85: does> ( addr1 -- addr2 )
86: @ + ;
87:
88: : const-field
89: <builds-field ( n1 n2 -- n3 )
90: does> ( addr -- w )
91: @ + @ ;
92:
93: struct
94: 2 cells field item-name
95: cell field item-d-offset
96: cell field item-f-offset
97: cell field item-type
98: constant item-descr
99:
100: 2variable forth-name
101: 2variable wordset
102: 2variable c-name
103: 2variable doc
104: 2variable c-code
105: 2variable forth-code
106: 2variable stack-string
107: create effect-in max-effect item-descr * allot
108: create effect-out max-effect item-descr * allot
109: variable effect-in-end ( pointer )
110: variable effect-out-end ( pointer )
111: 2variable effect-in-size
112: 2variable effect-out-size
113: variable c-line
114: 2variable c-filename
115: variable name-line
116: 2variable name-filename
117: 2variable last-name-filename
118:
119: variable primitive-number -10 primitive-number !
120:
121: \ for several reasons stack items of a word are stored in a wordlist
122: \ since neither forget nor marker are implemented yet, we make a new
123: \ wordlist for every word and store it in the variable items
124: variable items
125:
126: \ a few more set ops
127:
128: : bit-equivalent ( w1 w2 -- w3 )
129: xor invert ;
130:
131: : complement ( set1 -- set2 )
132: empty ['] bit-equivalent binary-set-operation ;
133:
134: \ the parser
135:
136: eof-char max-member \ the whole character set + EOF
137:
138: : getinput ( -- n )
139: rawinput @ endrawinput @ =
140: if
141: eof-char
142: else
143: cookedinput @ c@
144: endif ;
145:
146: :noname ( n -- )
147: dup bl > if
148: emit space
149: else
150: .
151: endif ;
152: print-token !
153:
154: : testchar? ( set -- f )
155: getinput member? ;
156: ' testchar? test-vector !
157:
158: : checksyncline ( -- )
159: \ when input points to a newline, check if the next line is a
160: \ sync line. If it is, perform the appropriate actions.
161: rawinput @ >r
162: s" #line " r@ over compare 0<> if
163: rdrop 1 line +! EXIT
164: endif
165: 0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )
166: dup c@ bl = if
167: char+ dup c@ [char] " <> abort" sync line syntax"
168: char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2!
169: char+
170: endif
171: dup c@ nl-char <> abort" sync line syntax"
172: skipsynclines @ if
173: dup char+ rawinput !
174: rawinput @ c@ cookedinput @ c!
175: endif
176: drop ;
177:
178: : ?nextchar ( f -- )
179: ?not? if
180: filename 2@ type ." :" line @ 0 .r ." : syntax error, wrong char:"
181: getinput . cr
182: rawinput @ endrawinput @ over - 100 min type cr
183: abort
184: endif
185: rawinput @ endrawinput @ <> if
186: rawinput @ c@
187: 1 chars rawinput +!
188: 1 chars cookedinput +!
189: nl-char = if
190: checksyncline
191: endif
192: rawinput @ c@ cookedinput @ c!
193: endif ;
194:
195: : charclass ( set "name" -- )
196: ['] ?nextchar terminal ;
197:
198: : .. ( c1 c2 -- set )
199: ( creates a set that includes the characters c, c1<=c<=c2 )
200: empty copy-set
201: swap 1+ rot do
202: i over add-member
203: loop ;
204:
205: : ` ( -- terminal ) ( use: ` c )
206: ( creates anonymous terminal for the character c )
207: char singleton ['] ?nextchar make-terminal ;
208:
209: char a char z .. char A char Z .. union char _ singleton union charclass letter
210: char 0 char 9 .. charclass digit
211: bl singleton charclass blank
212: tab-char singleton charclass tab
213: nl-char singleton eof-char over add-member complement charclass nonl
214: nl-char singleton eof-char over add-member char : over add-member complement charclass nocolonnl
215: bl 1+ maxchar .. charclass nowhite
216: char " singleton eof-char over add-member complement charclass noquote
217: nl-char singleton charclass nl
218: eof-char singleton charclass eof
219:
220:
221: (( letter (( letter || digit )) **
222: )) <- c-name ( -- )
223:
224: nowhite ++
225: <- name ( -- )
226:
227: (( ` \ nonl ** nl
228: )) <- comment ( -- )
229:
230: (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-in-end ! }}
231: ` - ` - blank **
232: {{ effect-out }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-out-end ! }}
233: )) <- stack-effect ( -- )
234:
235: (( {{ s" " doc 2! s" " forth-code 2! }}
236: (( comment || nl )) **
237: (( {{ line @ name-line ! filename 2@ name-filename 2! }}
238: {{ start }} name {{ end 2dup forth-name 2! c-name 2! }} tab ++
239: {{ start }} stack-effect {{ end stack-string 2! }} tab ++
240: {{ start }} name {{ end wordset 2! }} tab **
241: (( {{ start }} c-name {{ end c-name 2! }} )) ?? nl
242: ))
243: (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ??
244: {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl ** nl )) ** {{ end c-code 2! skipsynclines on }}
245: (( ` : nl
246: {{ start }} (( nonl ++ nl )) ++ {{ end forth-code 2! }}
247: )) ??
248: (( nl || eof ))
249: )) <- primitive ( -- )
250:
251: (( (( primitive {{ printprim }} )) ** eof ))
252: parser primitives2something
253: warnings @ [IF]
254: .( parser generated ok ) cr
255: [THEN]
256:
257: : primfilter ( file-id xt -- )
258: \ fileid is for the input file, xt ( -- ) is for the output word
259: output !
260: here dup rawinput ! cookedinput !
261: here swap read-whole-file
262: dup endrawinput !
263: here - allot
264: align
265: checksyncline
266: \ begin
267: \ getinput dup eof-char = ?EXIT emit true ?nextchar
268: \ again ;
269: primitives2something ;
270:
271: \ types
272:
273: struct
274: 2 cells field type-c-name
275: cell const-field type-d-size
276: cell const-field type-f-size
277: cell const-field type-fetch-handler
278: cell const-field type-store-handler
279: constant type-description
280:
281: : data-stack-access ( n1 n2 n3 -- )
282: \ n1 is the offset of the accessed item, n2, n3 are effect-*-size
283: drop swap - 1- dup
284: if
285: ." sp[" 0 .r ." ]"
286: else
287: drop ." TOS"
288: endif ;
289:
290: : fp-stack-access ( n1 n2 n3 -- )
291: \ n1 is the offset of the accessed item, n2, n3 are effect-*-size
292: nip swap - 1- dup
293: if
294: ." fp[" 0 .r ." ]"
295: else
296: drop ." FTOS"
297: endif ;
298:
299: : fetch-single ( item -- )
300: >r
301: r@ item-name 2@ type
302: ." = ("
303: r@ item-type @ type-c-name 2@ type ." ) "
304: r@ item-d-offset @ effect-in-size 2@ data-stack-access ." ;" cr
305: rdrop ;
306:
307: : fetch-double ( item -- )
308: >r
309: ." FETCH_DCELL("
310: r@ item-name 2@ type ." , "
311: r@ item-d-offset @ dup effect-in-size 2@ data-stack-access
312: ." , " 1+ effect-in-size 2@ data-stack-access
313: ." );" cr
314: rdrop ;
315:
316: : fetch-float ( item -- )
317: >r
318: r@ item-name 2@ type
319: ." = "
320: \ ." (" r@ item-type @ type-c-name 2@ type ." ) "
321: r@ item-f-offset @ effect-in-size 2@ fp-stack-access ." ;" cr
322: rdrop ;
323:
324: : d-same-as-in? ( item -- f )
325: \ f is true iff the offset of item is the same as on input
326: >r
327: r@ item-name 2@ items @ search-wordlist 0=
328: abort" bug"
329: execute @
330: dup r@ =
331: if \ item first appeared in output
332: drop false
333: else
334: item-d-offset @ r@ item-d-offset @ =
335: endif
336: rdrop ;
337:
338: : is-in-tos? ( item -- f )
339: \ true if item has the same offset as the input TOS
340: item-d-offset @ 1+ effect-in-size 2@ drop = ;
341:
342: : really-store-single ( item -- )
343: >r
344: r@ item-d-offset @ effect-out-size 2@ data-stack-access ." = (Cell)"
345: r@ item-name 2@ type ." ;"
346: rdrop ;
347:
348: : store-single ( item -- )
349: >r
350: r@ d-same-as-in?
351: if
352: r@ is-in-tos?
353: if
354: ." IF_TOS(" r@ really-store-single ." );" cr
355: endif
356: else
357: r@ really-store-single cr
358: endif
359: rdrop ;
360:
361: : store-double ( item -- )
362: \ !! store optimization is not performed, because it is not yet needed
363: >r
364: ." STORE_DCELL(" r@ item-name 2@ type ." , "
365: r@ item-d-offset @ dup effect-out-size 2@ data-stack-access
366: ." , " 1+ effect-out-size 2@ data-stack-access
367: ." );" cr
368: rdrop ;
369:
370: : f-same-as-in? ( item -- f )
371: \ f is true iff the offset of item is the same as on input
372: >r
373: r@ item-name 2@ items @ search-wordlist 0=
374: abort" bug"
375: execute @
376: dup r@ =
377: if \ item first appeared in output
378: drop false
379: else
380: item-f-offset @ r@ item-f-offset @ =
381: endif
382: rdrop ;
383:
384: : is-in-ftos? ( item -- f )
385: \ true if item has the same offset as the input TOS
386: item-f-offset @ 1+ effect-in-size 2@ nip = ;
387:
388: : really-store-float ( item -- )
389: >r
390: r@ item-f-offset @ effect-out-size 2@ fp-stack-access ." = "
391: r@ item-name 2@ type ." ;"
392: rdrop ;
393:
394: : store-float ( item -- )
395: >r
396: r@ f-same-as-in?
397: if
398: r@ is-in-ftos?
399: if
400: ." IF_FTOS(" r@ really-store-float ." );" cr
401: endif
402: else
403: r@ really-store-float cr
404: endif
405: rdrop ;
406:
407: : single-type ( -- xt1 xt2 n1 n2 )
408: ['] fetch-single ['] store-single 1 0 ;
409:
410: : double-type ( -- xt1 xt2 n1 n2 )
411: ['] fetch-double ['] store-double 2 0 ;
412:
413: : float-type ( -- xt1 xt2 n1 n2 )
414: ['] fetch-float ['] store-float 0 1 ;
415:
416: : s, ( addr u -- )
417: \ allocate a string
418: here swap dup allot move ;
419:
420: : starts-with ( addr u xt1 xt2 n1 n2 "prefix" -- )
421: \ describes a type
422: \ addr u specifies the C type name
423: \ n1 is the size of the type on the data stack
424: \ n2 is the size of the type on the FP stack
425: \ stack effect entries of the type start with prefix
426: >r >r >r >r
427: dup >r here >r s,
428: create
429: r> r> 2,
430: r> r> r> , r> , swap , , ;
431:
432: wordlist constant types
433: get-current
434: types set-current
435:
436: s" Bool" single-type starts-with f
437: s" Char" single-type starts-with c
438: s" Cell" single-type starts-with n
439: s" Cell" single-type starts-with w
440: s" UCell" single-type starts-with u
441: s" DCell" double-type starts-with d
442: s" UDCell" double-type starts-with ud
443: s" Float" float-type starts-with r
444: s" Cell *" single-type starts-with a_
445: s" Char *" single-type starts-with c_
446: s" Float *" single-type starts-with f_
447: s" DFloat *" single-type starts-with df_
448: s" SFloat *" single-type starts-with sf_
449: s" Xt" single-type starts-with xt
450: s" WID" single-type starts-with wid
451: s" F83Name *" single-type starts-with f83name
452:
453: set-current
454:
455: : get-type ( addr1 u1 -- type-descr )
456: \ get the type of the name in addr1 u1
457: \ type-descr is a pointer to a type-descriptor
458: 0 swap ?do
459: dup i types search-wordlist
460: if \ ok, we have the type ( addr1 xt )
461: execute nip
462: UNLOOP EXIT
463: endif
464: -1 s+loop
465: \ we did not find a type, abort
466: true abort" unknown type prefix" ;
467:
468: : declare ( addr "name" -- )
469: \ remember that there is a stack item at addr called name
470: create , ;
471:
472: : declaration ( item -- )
473: dup item-name 2@ items @ search-wordlist
474: if \ already declared ( item xt )
475: execute @ item-type @ swap item-type !
476: else ( addr )
477: dup item-name 2@ nextname dup declare ( addr )
478: dup >r item-name 2@ 2dup get-type ( addr1 u type-descr )
479: dup r> item-type ! ( addr1 u type-descr )
480: type-c-name 2@ type space type ." ;" cr
481: endif ;
482:
483: : declaration-list ( addr1 addr2 -- )
484: swap ?do
485: i declaration
486: item-descr +loop ;
487:
488: : fetch ( addr -- )
489: dup item-type @ type-fetch-handler execute ;
490:
491: : declarations ( -- )
492: wordlist dup items ! set-current
493: effect-in effect-in-end @ declaration-list
494: effect-out effect-out-end @ declaration-list ;
495:
496: \ offset computation
497: \ the leftmost (i.e. deepest) item has offset 0
498: \ the rightmost item has the highest offset
499:
500: : compute-offset ( n1 n2 item -- n3 n4 )
501: \ n1, n3 are data-stack-offsets
502: \ n2, n4 are the fp-stack-offsets
503: >r
504: swap dup r@ item-d-offset !
505: r@ item-type @ type-d-size +
506: swap dup r@ item-f-offset !
507: r@ item-type @ type-f-size +
508: rdrop ;
509:
510: : compute-list ( addr1 addr2 -- n1 n2 )
511: \ n1, n2 are the final offsets
512: 0 0 2swap swap ?do
513: i compute-offset
514: item-descr +loop ;
515:
516: : compute-offsets ( -- )
517: effect-in effect-in-end @ compute-list effect-in-size 2!
518: effect-out effect-out-end @ compute-list effect-out-size 2! ;
519:
520: : flush-tos ( -- )
521: effect-in-size 2@ effect-out-size 2@
522: 0<> rot 0= and
523: if
524: ." IF_FTOS(fp[0] = FTOS);" cr
525: endif
526: 0<> swap 0= and
527: if
528: ." IF_TOS(sp[0] = TOS);" cr
529: endif ;
530:
531: : fill-tos ( -- )
532: effect-in-size 2@ effect-out-size 2@
533: 0= rot 0<> and
534: if
535: ." IF_FTOS(FTOS = fp[0]);" cr
536: endif
537: 0= swap 0<> and
538: if
539: ." IF_TOS(TOS = sp[0]);" cr
540: endif ;
541:
542: : fetches ( -- )
543: effect-in-end @ effect-in ?do
544: i fetch
545: item-descr +loop ;
546:
547: : stack-pointer-updates ( -- )
548: \ we need not check if an update is a noop; gcc does this for us
549: effect-in-size 2@
550: effect-out-size 2@
551: rot swap - ( d-in d-out f-diff )
552: rot rot - ( f-diff d-diff )
553: ?dup IF ." sp += " 0 .r ." ;" cr THEN
554: ?dup IF ." fp += " 0 .r ." ;" cr THEN ;
555:
556: : store ( item -- )
557: \ f is true if the item should be stored
558: \ f is false if the store is probably not necessary
559: dup item-type @ type-store-handler execute ;
560:
561: : stores ( -- )
562: effect-out-end @ effect-out ?do
563: i store
564: item-descr +loop ;
565:
566: : .stack-list ( start end -- )
567: swap ?do
568: i item-name 2@ type space
569: item-descr +loop ;
570:
571: : output-c ( -- )
572: ." I_" c-name 2@ type ." : /* " forth-name 2@ type ." ( " stack-string 2@ type ." ) */" cr
573: ." /* " doc 2@ type ." */" cr
574: ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging
575: ." {" cr
576: ." DEF_CA" cr
577: declarations
578: compute-offsets \ for everything else
579: ." NEXT_P0;" cr
580: flush-tos
581: fetches
582: stack-pointer-updates
583: ." {" cr
584: ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr
585: c-code 2@ type
586: ." }" cr
587: ." NEXT_P1;" cr
588: stores
589: fill-tos
590: ." NEXT_P2;" cr
591: ." }" cr
592: cr
593: ;
594:
595: : output-label ( -- )
596: ." &&I_" c-name 2@ type ." ," cr ;
597:
598: : output-alias ( -- )
599: primitive-number @ . ." alias " forth-name 2@ type cr
600: -1 primitive-number +! ;
601:
602: : output-forth ( -- )
603: forth-code @ 0=
604: IF output-alias
605: ELSE ." : " forth-name 2@ type ." ( "
606: effect-in effect-in-end @ .stack-list ." -- "
607: effect-out effect-out-end @ .stack-list ." )" cr
608: forth-code 2@ type cr
609: -1 primitive-number +!
610: THEN ;
611:
612: : output-tag-file ( -- )
613: name-filename 2@ last-name-filename 2@ compare if
614: name-filename 2@ last-name-filename 2!
615: #ff emit cr
616: name-filename 2@ type
617: ." ,0" cr
618: endif ;
619:
620: : output-tag ( -- )
621: output-tag-file
622: forth-name 2@ 1+ type
623: 127 emit
624: space forth-name 2@ type space
625: 1 emit
626: name-line @ 0 .r
627: ." ,0" cr ;
628:
629: [IFDEF] documentation
630: : register-doc ( -- )
631: get-current documentation set-current
632: forth-name 2@ nextname create
633: forth-name 2@ 2,
634: stack-string 2@ condition-stack-effect 2,
635: wordset 2@ 2,
636: c-name 2@ condition-pronounciation 2,
637: doc 2@ 2,
638: set-current ;
639: [THEN]
640:
641: : process-file ( addr u xt -- )
642: >r
643: 2dup filename 2!
644: r/o open-file abort" cannot open file"
645: warnings @ if
646: ." ------------ CUT HERE -------------" cr endif
647: r> primfilter ;
648:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>