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