1: \ converts primitives to, e.g., C code
2:
3: \ Copyright (C) 1995,1996,1997,1998,2000 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., 59 Temple Place, Suite 330, Boston, MA 02111, 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 \ we are executed just with kernel image
46: \ load the rest that is needed
47: \ (require fails because this file is needed from a
48: \ different directory with the wordlibraries)
49: include ./search.fs
50: include ./extend.fs
51: [THEN]
52:
53: [IFUNDEF] environment?
54: include ./environ.fs
55: [THEN]
56:
57: : struct% struct ; \ struct is redefined in gray
58:
59: include ./gray.fs
60:
61: 100 constant max-effect \ number of things on one side of a stack effect
62: 255 constant maxchar
63: maxchar 1+ constant eof-char
64: #tab constant tab-char
65: #lf constant nl-char
66:
67: variable rawinput \ pointer to next character to be scanned
68: variable endrawinput \ pointer to the end of the input (the char after the last)
69: variable cookedinput \ pointer to the next char to be parsed
70: variable line \ line number of char pointed to by input
71: variable line-start \ pointer to start of current line (for error messages)
72: 0 line !
73: 2variable filename \ filename of original input file
74: 0 0 filename 2!
75: 2variable f-comment
76: 0 0 f-comment 2!
77: variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?
78: skipsynclines on
79:
80: : start ( -- addr )
81: cookedinput @ ;
82:
83: : end ( addr -- addr u )
84: cookedinput @ over - ;
85:
86: : quote ( -- )
87: [char] " emit ;
88:
89: variable output \ xt ( -- ) of output word
90:
91: : printprim ( -- )
92: output @ execute ;
93:
94: struct%
95: cell% 2* field stack-pointer \ stackpointer name
96: cell% 2* field stack-cast \ cast string for assignments to stack elements
97: cell% field stack-in-index-xt \ ( in-size item -- in-index )
98: cell% field stack-in \ number of stack items in effect in
99: cell% field stack-out \ number of stack items in effect out
100: end-struct stack%
101:
102: struct%
103: cell% 2* field item-name \ name, excluding stack prefixes
104: cell% field item-stack \ descriptor for the stack used, 0 is default
105: cell% field item-type \ descriptor for the item type
106: cell% field item-offset \ offset in stack items, 0 for the deepest element
107: cell% field item-first \ true if this is the first occurence of the item
108: end-struct item%
109:
110: struct%
111: cell% 2* field type-c-name
112: cell% field type-stack \ default stack
113: cell% field type-size \ size of type in stack items
114: cell% field type-fetch \ xt of fetch code generator ( item -- )
115: cell% field type-store \ xt of store code generator ( item -- )
116: end-struct type%
117:
118: : stack-in-index ( in-size item -- in-index )
119: item-offset @ - 1- ;
120:
121: : inst-in-index ( in-size item -- in-index )
122: nip dup item-offset @ swap item-type @ type-size @ + 1- ;
123:
124: : make-stack ( addr-ptr u1 addr-cast u2 "stack-name" -- )
125: create stack% %allot >r
126: save-mem r@ stack-cast 2!
127: save-mem r@ stack-pointer 2!
128: ['] stack-in-index r> stack-in-index-xt ! ;
129:
130: s" sp" save-mem s" (Cell)" make-stack data-stack
131: s" fp" save-mem s" " make-stack fp-stack
132: s" rp" save-mem s" (Cell)" make-stack return-stack
133: s" IP" save-mem s" error don't use # on results" make-stack inst-stream
134: ' inst-in-index inst-stream stack-in-index-xt !
135: \ !! initialize stack-in and stack-out
136:
137: \ stack items
138:
139: : init-item ( addr u addr1 -- )
140: \ initialize item at addr1 with name addr u
141: \ !! remove stack prefix
142: dup item% %size erase
143: item-name 2! ;
144:
145: : map-items { addr end xt -- }
146: \ perform xt for all items in array addr...end
147: end addr ?do
148: i xt execute
149: item% %size +loop ;
150:
151: \ various variables for storing stuff of one primitive
152:
153: 2variable forth-name
154: 2variable wordset
155: 2variable c-name
156: 2variable doc
157: 2variable c-code
158: 2variable forth-code
159: 2variable stack-string
160: create effect-in max-effect item% %size * allot
161: create effect-out max-effect item% %size * allot
162: variable effect-in-end ( pointer )
163: variable effect-out-end ( pointer )
164: variable c-line
165: 2variable c-filename
166: variable name-line
167: 2variable name-filename
168: 2variable last-name-filename
169:
170: variable primitive-number -10 primitive-number !
171: Variable function-number 0 function-number !
172:
173: \ for several reasons stack items of a word are stored in a wordlist
174: \ since neither forget nor marker are implemented yet, we make a new
175: \ wordlist for every word and store it in the variable items
176: variable items
177:
178: \ a few more set ops
179:
180: : bit-equivalent ( w1 w2 -- w3 )
181: xor invert ;
182:
183: : complement ( set1 -- set2 )
184: empty ['] bit-equivalent binary-set-operation ;
185:
186: \ the parser
187:
188: eof-char max-member \ the whole character set + EOF
189:
190: : getinput ( -- n )
191: rawinput @ endrawinput @ =
192: if
193: eof-char
194: else
195: cookedinput @ c@
196: endif ;
197:
198: :noname ( n -- )
199: dup bl > if
200: emit space
201: else
202: .
203: endif ;
204: print-token !
205:
206: : testchar? ( set -- f )
207: getinput member? ;
208: ' testchar? test-vector !
209:
210: : checksyncline ( -- )
211: \ when input points to a newline, check if the next line is a
212: \ sync line. If it is, perform the appropriate actions.
213: rawinput @ >r
214: s" #line " r@ over compare 0<> if
215: rdrop 1 line +! EXIT
216: endif
217: 0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )
218: dup c@ bl = if
219: char+ dup c@ [char] " <> abort" sync line syntax"
220: char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2!
221: char+
222: endif
223: dup c@ nl-char <> abort" sync line syntax"
224: skipsynclines @ if
225: dup char+ rawinput !
226: rawinput @ c@ cookedinput @ c!
227: endif
228: drop ;
229:
230: : print-error-line ( -- )
231: \ print the current line and position
232: line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end )
233: over - type cr
234: line-start @ rawinput @ over - typewhite ." ^" cr ;
235:
236: : ?nextchar ( f -- )
237: ?not? if
238: outfile-id >r try
239: stderr to outfile-id
240: filename 2@ type ." :" line @ 0 .r ." : syntax error, wrong char:"
241: getinput . cr
242: print-error-line
243: 0
244: recover endtry
245: r> to outfile-id throw
246: abort
247: endif
248: rawinput @ endrawinput @ <> if
249: rawinput @ c@
250: 1 chars rawinput +!
251: 1 chars cookedinput +!
252: nl-char = if
253: checksyncline
254: rawinput @ line-start !
255: endif
256: rawinput @ c@ cookedinput @ c!
257: endif ;
258:
259: : charclass ( set "name" -- )
260: ['] ?nextchar terminal ;
261:
262: : .. ( c1 c2 -- set )
263: ( creates a set that includes the characters c, c1<=c<=c2 )
264: empty copy-set
265: swap 1+ rot do
266: i over add-member
267: loop ;
268:
269: : ` ( -- terminal ) ( use: ` c )
270: ( creates anonymous terminal for the character c )
271: char singleton ['] ?nextchar make-terminal ;
272:
273: char a char z .. char A char Z .. union char _ singleton union charclass letter
274: char 0 char 9 .. charclass digit
275: bl singleton tab-char over add-member charclass white
276: nl-char singleton eof-char over add-member complement charclass nonl
277: nl-char singleton eof-char over add-member
278: char : over add-member complement charclass nocolonnl
279: bl 1+ maxchar .. char \ singleton complement intersection
280: charclass nowhitebq
281: bl 1+ maxchar .. charclass nowhite
282: char " singleton eof-char over add-member complement charclass noquote
283: nl-char singleton charclass nl
284: eof-char singleton charclass eof
285:
286:
287: (( letter (( letter || digit )) **
288: )) <- c-ident ( -- )
289:
290: (( ` # ?? (( letter || digit || ` : )) **
291: )) <- stack-ident ( -- )
292:
293: (( nowhitebq nowhite ** ))
294: <- forth-ident ( -- )
295:
296: Variable forth-flag
297: Variable c-flag
298:
299: (( (( ` e || ` E )) {{ start }} nonl **
300: {{ end evaluate }}
301: )) <- eval-comment ( ... -- ... )
302:
303: (( (( ` f || ` F )) {{ start }} nonl **
304: {{ end forth-flag @ IF type cr ELSE 2drop THEN }}
305: )) <- forth-comment ( -- )
306:
307: (( (( ` c || ` C )) {{ start }} nonl **
308: {{ end c-flag @ IF type cr ELSE 2drop THEN }}
309: )) <- c-comment ( -- )
310:
311: (( ` - nonl ** {{
312: forth-flag @ IF ." [ELSE]" cr THEN
313: c-flag @ IF ." #else" cr THEN }}
314: )) <- else-comment
315:
316: (( ` + {{ start }} nonl ** {{ end
317: dup
318: IF c-flag @
319: IF ." #ifdef HAS_" bounds ?DO I c@ toupper emit LOOP cr
320: THEN
321: forth-flag @
322: IF ." has? " type ." [IF]" cr THEN
323: ELSE 2drop
324: c-flag @ IF ." #endif" cr THEN
325: forth-flag @ IF ." [THEN]" cr THEN
326: THEN }}
327: )) <- if-comment
328:
329: (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment )) ?? nonl ** )) <- comment-body
330:
331: (( ` \ comment-body nl )) <- comment ( -- )
332:
333: (( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) **
334: <- stack-items
335:
336: (( {{ effect-in }} stack-items {{ effect-in-end ! }}
337: ` - ` - white **
338: {{ effect-out }} stack-items {{ effect-out-end ! }}
339: )) <- stack-effect ( -- )
340:
341: (( {{ s" " doc 2! s" " forth-code 2! s" " wordset 2! }}
342: (( {{ line @ name-line ! filename 2@ name-filename 2! }}
343: {{ start }} forth-ident {{ end 2dup forth-name 2! c-name 2! }} white ++
344: ` ( white ** {{ start }} stack-effect {{ end stack-string 2! }} ` ) white **
345: (( {{ start }} forth-ident {{ end wordset 2! }} white **
346: (( {{ start }} c-ident {{ end c-name 2! }} )) ??
347: )) ?? nl
348: ))
349: (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " white ** nl )) ??
350: {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl ** nl white ** )) ** {{ end c-code 2! skipsynclines on }}
351: (( ` : white ** nl
352: {{ start }} (( nonl ++ nl white ** )) ++ {{ end forth-code 2! }}
353: )) ?? {{ printprim }}
354: (( nl || eof ))
355: )) <- primitive ( -- )
356:
357: (( (( comment || primitive || nl white ** )) ** eof ))
358: parser primitives2something
359: warnings @ [IF]
360: .( parser generated ok ) cr
361: [THEN]
362:
363: : primfilter ( file-id xt -- )
364: \ fileid is for the input file, xt ( -- ) is for the output word
365: output !
366: here dup rawinput ! dup line-start ! cookedinput !
367: here unused rot read-file throw
368: dup here + endrawinput !
369: allot
370: align
371: checksyncline
372: \ begin
373: \ getinput dup eof-char = ?EXIT emit true ?nextchar
374: \ again ;
375: primitives2something ;
376:
377: \ types
378:
379: : stack-access ( n stack -- )
380: \ print a stack access at index n of stack
381: stack-pointer 2@ type
382: dup
383: if
384: ." [" 0 .r ." ]"
385: else
386: drop ." TOS"
387: endif ;
388:
389: : item-in-index { item -- n }
390: \ n is the index of item (in the in-effect)
391: item item-stack @ dup >r stack-in @ ( in-size r:stack )
392: item r> stack-in-index-xt @ execute ;
393:
394: : fetch-single ( item -- )
395: \ fetch a single stack item from its stack
396: >r
397: r@ item-name 2@ type
398: ." = ("
399: r@ item-type @ type-c-name 2@ type ." ) "
400: r@ item-in-index r@ item-stack @ stack-access
401: ." ;" cr
402: rdrop ;
403:
404: : fetch-double ( item -- )
405: \ fetch a double stack item from its stack
406: >r
407: ." FETCH_DCELL("
408: r@ item-name 2@ type ." , "
409: r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access
410: ." , " -1 under+ ." (Cell)" stack-access
411: ." );" cr
412: rdrop ;
413:
414: : same-as-in? ( item -- f )
415: \ f is true iff the offset and stack of item is the same as on input
416: >r
417: r@ item-name 2@ items @ search-wordlist 0=
418: abort" bug"
419: execute @
420: dup r@ =
421: if \ item first appeared in output
422: drop false
423: else
424: dup item-stack @ r@ item-stack @ =
425: swap item-offset @ r@ item-offset @ = and
426: endif
427: rdrop ;
428:
429: : item-out-index ( item -- n )
430: \ n is the index of item (in the in-effect)
431: >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ;
432:
433: : really-store-single ( item -- )
434: >r
435: r@ item-out-index r@ item-stack @ stack-access ." = "
436: r@ item-stack @ stack-cast 2@ type
437: r@ item-name 2@ type ." ;"
438: rdrop ;
439:
440: : store-single ( item -- )
441: >r
442: r@ same-as-in?
443: if
444: r@ item-in-index 0= r@ item-out-index 0= xor
445: if
446: ." IF_" r@ item-stack @ stack-pointer 2@ type
447: ." TOS(" r@ really-store-single ." );" cr
448: endif
449: else
450: r@ really-store-single cr
451: endif
452: rdrop ;
453:
454: : store-double ( item -- )
455: \ !! store optimization is not performed, because it is not yet needed
456: >r
457: ." STORE_DCELL(" r@ item-name 2@ type ." , "
458: r@ item-out-index r@ item-stack @ 2dup stack-access
459: ." , " -1 under+ stack-access
460: ." );" cr
461: rdrop ;
462:
463: : single ( -- xt1 xt2 n )
464: ['] fetch-single ['] store-single 1 ;
465:
466: : double ( -- xt1 xt2 n )
467: ['] fetch-double ['] store-double 2 ;
468:
469: : s, ( addr u -- )
470: \ allocate a string
471: here swap dup allot move ;
472:
473: wordlist constant prefixes
474:
475: : declare ( addr "name" -- )
476: \ remember that there is a stack item at addr called name
477: create , ;
478:
479: : !default ( w addr -- )
480: dup @ if
481: 2drop \ leave nonzero alone
482: else
483: !
484: endif ;
485:
486: : create-type { addr u xt1 xt2 n stack -- } ( "prefix" -- )
487: \ describes a type
488: \ addr u specifies the C type name
489: \ stack effect entries of the type start with prefix
490: create type% %allot >r
491: addr u save-mem r@ type-c-name 2!
492: xt1 r@ type-fetch !
493: xt2 r@ type-store !
494: n r@ type-size !
495: stack r@ type-stack !
496: rdrop ;
497:
498: : type-prefix ( xt1 xt2 n stack "prefix" -- )
499: create-type
500: does> ( item -- )
501: \ initialize item
502: { item typ }
503: typ item item-type !
504: typ type-stack @ item item-stack !default
505: item item-name 2@ items @ search-wordlist 0= if \ new name
506: item item-name 2@ nextname item declare
507: item item-first on
508: \ typ type-c-name 2@ type space type ." ;" cr
509: else
510: drop
511: item item-first off
512: endif ;
513:
514: : execute-prefix ( item addr1 u1 -- )
515: \ execute the word ( item -- ) associated with the longest prefix
516: \ of addr1 u1
517: 0 swap ?do
518: dup i prefixes search-wordlist
519: if \ ok, we have the type ( item addr1 xt )
520: nip execute
521: UNLOOP EXIT
522: endif
523: -1 s+loop
524: \ we did not find a type, abort
525: true abort" unknown prefix" ;
526:
527: : declaration ( item -- )
528: dup item-name 2@ execute-prefix ;
529:
530: : declaration-list ( addr1 addr2 -- )
531: ['] declaration map-items ;
532:
533: : declarations ( -- )
534: wordlist dup items ! set-current
535: effect-in effect-in-end @ declaration-list
536: effect-out effect-out-end @ declaration-list ;
537:
538: : print-declaration { item -- }
539: item item-first @ if
540: item item-type @ type-c-name 2@ type space
541: item item-name 2@ type ." ;" cr
542: endif ;
543:
544: : print-declarations ( -- )
545: effect-in effect-in-end @ ['] print-declaration map-items
546: effect-out effect-out-end @ ['] print-declaration map-items ;
547:
548: : stack-prefix ( stack "prefix" -- )
549: name tuck nextname create ( stack length ) 2,
550: does> ( item -- )
551: 2@ { item stack prefix-length }
552: item item-name 2@ prefix-length /string item item-name 2!
553: stack item item-stack !
554: item declaration ;
555:
556: \ offset computation
557: \ the leftmost (i.e. deepest) item has offset 0
558: \ the rightmost item has the highest offset
559:
560: : compute-offset { item xt -- }
561: \ xt specifies in/out; update stack-in/out and set item-offset
562: item item-type @ type-size @
563: item item-stack @ xt execute dup @ >r +!
564: r> item item-offset ! ;
565:
566: : compute-offset-in ( addr1 addr2 -- )
567: ['] stack-in compute-offset ;
568:
569: : compute-offset-out ( addr1 addr2 -- )
570: ['] stack-out compute-offset ;
571:
572: : clear-stack { -- }
573: dup stack-in off stack-out off ;
574:
575: : compute-offsets ( -- )
576: data-stack clear-stack fp-stack clear-stack return-stack clear-stack
577: inst-stream clear-stack
578: effect-in effect-in-end @ ['] compute-offset-in map-items
579: effect-out effect-out-end @ ['] compute-offset-out map-items
580: inst-stream stack-out @ 0<> abort" # can only be on the input side" ;
581:
582: : flush-a-tos { stack -- }
583: stack stack-out @ 0<> stack stack-in @ 0= and
584: if
585: ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
586: 2dup type ." [0] = " type ." TOS);" cr
587: endif ;
588:
589: : flush-tos ( -- )
590: data-stack flush-a-tos
591: fp-stack flush-a-tos
592: return-stack flush-a-tos ;
593:
594: : fill-a-tos { stack -- }
595: stack stack-out @ 0= stack stack-in @ 0<> and
596: if
597: ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
598: 2dup type ." TOS = " type ." [0]);" cr
599: endif ;
600:
601: : fill-tos ( -- )
602: \ !! inst-stream for prefetching?
603: fp-stack fill-a-tos
604: data-stack fill-a-tos
605: return-stack fill-a-tos ;
606:
607: : fetch ( addr -- )
608: dup item-type @ type-fetch @ execute ;
609:
610: : fetches ( -- )
611: effect-in effect-in-end @ ['] fetch map-items ;
612:
613: : stack-pointer-update { stack -- }
614: \ stack grow downwards
615: stack stack-in @ stack stack-out @ -
616: ?dup-if \ this check is not necessary, gcc would do this for us
617: stack stack-pointer 2@ type ." += " 0 .r ." ;" cr
618: endif ;
619:
620: : inst-pointer-update ( -- )
621: inst-stream stack-in @ ?dup-if
622: ." INC_IP(" 0 .r ." );" cr
623: endif ;
624:
625: : stack-pointer-updates ( -- )
626: inst-pointer-update
627: data-stack stack-pointer-update
628: fp-stack stack-pointer-update
629: return-stack stack-pointer-update ;
630:
631: : store ( item -- )
632: \ f is true if the item should be stored
633: \ f is false if the store is probably not necessary
634: dup item-type @ type-store @ execute ;
635:
636: : stores ( -- )
637: effect-out effect-out-end @ ['] store map-items ;
638:
639: : output-c-tail ( -- )
640: \ the final part of the generated C code
641: ." NEXT_P1;" cr
642: stores
643: fill-tos
644: ." NEXT_P2;" cr ;
645:
646: : type-c ( c-addr u -- )
647: \ like TYPE, but replaces "TAIL;" with tail code
648: begin ( c-addr1 u1 )
649: 2dup s" TAIL;" search
650: while ( c-addr1 u1 c-addr3 u3 )
651: 2dup 2>r drop nip over - type
652: output-c-tail
653: 2r> 5 /string
654: \ !! resync #line missing
655: repeat
656: 2drop type ;
657:
658: : print-type-prefix ( type -- )
659: body> >head .name ;
660:
661: : print-debug-arg { item -- }
662: ." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); "
663: ." printarg_" item item-type @ print-type-prefix
664: ." (" item item-name 2@ type ." );" cr ;
665:
666: : print-debug-args ( -- )
667: ." #ifdef VM_DEBUG" cr
668: ." if (vm_debug) {" cr
669: effect-in effect-in-end @ ['] print-debug-arg map-items
670: ." fputc('\n', vm_out);" cr
671: ." }" cr
672: ." #endif" cr ;
673:
674: : output-c ( -- )
675: ." I_" c-name 2@ type ." : /* " forth-name 2@ type ." ( " stack-string 2@ type ." ) */" cr
676: ." /* " doc 2@ type ." */" cr
677: ." NAME(" quote forth-name 2@ type quote ." )" cr \ debugging
678: ." {" cr
679: ." DEF_CA" cr
680: declarations
681: compute-offsets \ for everything else
682: print-declarations
683: ." NEXT_P0;" cr
684: flush-tos
685: fetches
686: print-debug-args
687: stack-pointer-updates
688: ." {" cr
689: ." #line " c-line @ . quote c-filename 2@ type quote cr
690: c-code 2@ type-c
691: ." }" cr
692: output-c-tail
693: ." }" cr
694: cr
695: ;
696:
697: : disasm-arg { item -- }
698: item item-stack @ inst-stream = if
699: ." fputc(' ', vm_out); "
700: ." printarg_" item item-type @ print-type-prefix
701: ." ((" item item-type @ type-c-name 2@ type ." )"
702: ." ip[" item item-offset @ 1+ 0 .r ." ]);" cr
703: endif ;
704:
705: : disasm-args ( -- )
706: effect-in effect-in-end @ ['] disasm-arg map-items ;
707:
708: : output-disasm ( -- )
709: \ generate code for disassembling VM instructions
710: ." if (ip[0] == prim[" function-number @ 0 .r ." ]) {" cr
711: ." fputs(" quote forth-name 2@ type quote ." , vm_out);" cr
712: ." /* " declarations ." */" cr
713: compute-offsets
714: disasm-args
715: ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
716: ." } else "
717: 1 function-number +! ;
718:
719: : gen-arg-parm { item -- }
720: item item-stack @ inst-stream = if
721: ." , " item item-type @ type-c-name 2@ type space
722: item item-name 2@ type
723: endif ;
724:
725: : gen-args-parm ( -- )
726: effect-in effect-in-end @ ['] gen-arg-parm map-items ;
727:
728: : gen-arg-gen { item -- }
729: item item-stack @ inst-stream = if
730: ." genarg_" item item-type @ print-type-prefix
731: ." (ctp, " item item-name 2@ type ." );" cr
732: endif ;
733:
734: : gen-args-gen ( -- )
735: effect-in effect-in-end @ ['] gen-arg-gen map-items ;
736:
737: : output-gen ( -- )
738: \ generate C code for generating VM instructions
739: ." /* " declarations ." */" cr
740: compute-offsets
741: ." void gen_" c-name 2@ type ." (Inst **ctp" gen-args-parm ." )" cr
742: ." {" cr
743: ." gen_inst(ctp, vm_prim[" function-number @ 0 .r ." ]);" cr
744: gen-args-gen
745: ." }" cr
746: 1 function-number +! ;
747:
748: : stack-used? { stack -- f }
749: stack stack-in @ stack stack-out @ or 0<> ;
750:
751: : output-funclabel ( -- )
752: 1 function-number +!
753: ." &I_" c-name 2@ type ." ," cr ;
754:
755: : output-forthname ( -- )
756: 1 function-number +!
757: '" emit forth-name 2@ type '" emit ." ," cr ;
758:
759: : output-c-func ( -- )
760: \ used for word libraries
761: 1 function-number +!
762: ." Cell * I_" c-name 2@ type ." (Cell *SP, Cell **FP) /* " forth-name 2@ type
763: ." ( " stack-string 2@ type ." ) */" cr
764: ." /* " doc 2@ type ." */" cr
765: ." NAME(" quote forth-name 2@ type quote ." )" cr
766: \ debugging
767: ." {" cr
768: declarations
769: compute-offsets \ for everything else
770: print-declarations
771: inst-stream stack-used? IF ." Cell *ip=IP;" cr THEN
772: data-stack stack-used? IF ." Cell *sp=SP;" cr THEN
773: fp-stack stack-used? IF ." Cell *fp=*FP;" cr THEN
774: return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN
775: flush-tos
776: fetches
777: stack-pointer-updates
778: fp-stack stack-used? IF ." *FP=fp;" cr THEN
779: ." {" cr
780: ." #line " c-line @ . quote c-filename 2@ type quote cr
781: c-code 2@ type
782: ." }" cr
783: stores
784: fill-tos
785: ." return (sp);" cr
786: ." }" cr
787: cr ;
788:
789: : output-label ( -- )
790: ." (Label)&&I_" c-name 2@ type ." ," cr
791: -1 primitive-number +! ;
792:
793: : output-alias ( -- )
794: ( primitive-number @ . ." alias " ) ." Primitive " forth-name 2@ type cr
795: -1 primitive-number +! ;
796:
797: : output-forth ( -- )
798: forth-code @ 0=
799: IF \ output-alias
800: \ this is bad for ec: an alias is compiled if tho word does not exist!
801: \ JAW
802: ELSE ." : " forth-name 2@ type ." ( "
803: stack-string 2@ type ." )" cr
804: forth-code 2@ type cr
805: -1 primitive-number +!
806: THEN ;
807:
808: : output-tag-file ( -- )
809: name-filename 2@ last-name-filename 2@ compare if
810: name-filename 2@ last-name-filename 2!
811: #ff emit cr
812: name-filename 2@ type
813: ." ,0" cr
814: endif ;
815:
816: : output-tag ( -- )
817: output-tag-file
818: forth-name 2@ 1+ type
819: 127 emit
820: space forth-name 2@ type space
821: 1 emit
822: name-line @ 0 .r
823: ." ,0" cr ;
824:
825: [IFDEF] documentation
826: : register-doc ( -- )
827: get-current documentation set-current
828: forth-name 2@ nextname create
829: forth-name 2@ 2,
830: stack-string 2@ condition-stack-effect 2,
831: wordset 2@ 2,
832: c-name 2@ condition-pronounciation 2,
833: doc 2@ 2,
834: set-current ;
835: [THEN]
836:
837: : process-file ( addr u xt -- )
838: >r
839: save-mem 2dup filename 2!
840: 0 function-number !
841: r/o open-file abort" cannot open file"
842: warnings @ if
843: ." ------------ CUT HERE -------------" cr endif
844: r> primfilter ;
845:
846: : process ( xt -- )
847: bl word count rot
848: process-file ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>