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