File:
[gforth] /
gforth /
prims2x.fs
Revision
1.130:
download - view:
text,
annotated -
select for diffs
Thu Jan 30 16:14:31 2003 UTC (21 years, 1 month ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
eliminated some (hopefully outdated) hppa special treatments
rewrote hppa cacheflush
prims2x can now process CRLF inputs (but the output is partly unixified)
prims2x can now process several sync lines in sequence
minor fixes
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: \ And it grew even worse when it aged.
24:
25: \ Optimizations:
26: \ superfluous stores are removed. GCC removes the superfluous loads by itself
27: \ TOS and FTOS can be kept in register( variable)s.
28: \
29: \ Problems:
30: \ The TOS optimization is somewhat hairy. The problems by example:
31: \ 1) dup ( w -- w w ): w=TOS; sp-=1; sp[1]=w; TOS=w;
32: \ The store is not superfluous although the earlier opt. would think so
33: \ Alternatively: sp[0]=TOS; w=TOS; sp-=1; TOS=w;
34: \ 2) ( -- .. ): sp[0] = TOS; ... /* This additional store is necessary */
35: \ 3) ( .. -- ): ... TOS = sp[0]; /* as well as this load */
36: \ 4) ( -- ): /* but here they are unnecessary */
37: \ 5) Words that call NEXT themselves have to be done very carefully.
38: \
39: \ To do:
40: \ add the store optimization for doubles
41: \ regarding problem 1 above: It would be better (for over) to implement
42: \ the alternative
43: \ store optimization for combined instructions.
44:
45: \ Design Uglyness:
46:
47: \ - global state (values, variables) in connection with combined instructions.
48:
49: \ - index computation is different for instruction-stream and the
50: \ stacks; there are two mechanisms for dealing with that
51: \ (stack-in-index-xt and a test for stack==instruction-stream); there
52: \ should be only one.
53:
54: warnings off
55:
56: [IFUNDEF] try
57: include startup.fs
58: [THEN]
59:
60: : struct% struct ; \ struct is redefined in gray
61:
62: warnings off
63: \ warnings on
64:
65: include ./gray.fs
66: 32 constant max-effect \ number of things on one side of a stack effect
67: 4 constant max-stacks \ the max. number of stacks (including inst-stream).
68: 255 constant maxchar
69: maxchar 1+ constant eof-char
70: #tab constant tab-char
71: #lf constant nl-char
72:
73: variable rawinput \ pointer to next character to be scanned
74: variable endrawinput \ pointer to the end of the input (the char after the last)
75: variable cookedinput \ pointer to the next char to be parsed
76: variable line \ line number of char pointed to by input
77: variable line-start \ pointer to start of current line (for error messages)
78: 0 line !
79: 2variable filename \ filename of original input file
80: 0 0 filename 2!
81: 2variable out-filename \ filename of the output file (for sync lines)
82: 0 0 out-filename 2!
83: 2variable f-comment
84: 0 0 f-comment 2!
85: variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?
86: skipsynclines on
87: variable out-nls \ newlines in output (for output sync lines)
88: 0 out-nls !
89: variable store-optimization \ use store optimization?
90: store-optimization off
91:
92: variable include-skipped-insts
93: \ does the threaded code for a combined instruction include the cells
94: \ for the component instructions (true) or only the cells for the
95: \ inline arguments (false)
96: include-skipped-insts off
97:
98: variable immarg \ values for immediate arguments (to be used in IMM_ARG macros)
99: $12340000 immarg !
100:
101: : th ( addr1 n -- addr2 )
102: cells + ;
103:
104: : holds ( addr u -- )
105: \ like HOLD, but for a string
106: tuck + swap 0 +do
107: 1- dup c@ hold
108: loop
109: drop ;
110:
111: : insert-wordlist { c-addr u wordlist xt -- }
112: \ adds name "addr u" to wordlist using defining word xt
113: \ xt may cause additional stack effects
114: get-current >r wordlist set-current
115: c-addr u nextname xt execute
116: r> set-current ;
117:
118: : start ( -- addr )
119: cookedinput @ ;
120:
121: : end ( addr -- addr u )
122: cookedinput @ over - ;
123:
124: : print-error-line ( -- )
125: \ print the current line and position
126: line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end )
127: over - type cr
128: line-start @ rawinput @ over - typewhite ." ^" cr ;
129:
130: : ?print-error { f addr u -- }
131: f ?not? if
132: outfile-id >r try
133: stderr to outfile-id
134: filename 2@ type ." :" line @ 0 .r ." : " addr u type cr
135: print-error-line
136: 0
137: recover endtry
138: r> to outfile-id throw
139: 1 (bye) \ abort
140: endif ;
141:
142: : quote ( -- )
143: [char] " emit ;
144:
145: \ count output lines to generate sync lines for output
146:
147: : count-nls ( addr u -- )
148: bounds u+do
149: i c@ nl-char = negate out-nls +!
150: loop ;
151:
152: :noname ( addr u -- )
153: 2dup count-nls
154: defers type ;
155: is type
156:
157: variable output \ xt ( -- ) of output word for simple primitives
158: variable output-combined \ xt ( -- ) of output word for combined primitives
159:
160: struct%
161: cell% field stack-number \ the number of this stack
162: cell% 2* field stack-pointer \ stackpointer name
163: cell% field stack-type \ name for default type of stack items
164: cell% field stack-in-index-xt \ ( in-size item -- in-index )
165: cell% field stack-access-transform \ ( nitem -- index )
166: end-struct stack%
167:
168: struct%
169: cell% 2* field item-name \ name, excluding stack prefixes
170: cell% field item-stack \ descriptor for the stack used, 0 is default
171: cell% field item-type \ descriptor for the item type
172: cell% field item-offset \ offset in stack items, 0 for the deepest element
173: cell% field item-first \ true if this is the first occurence of the item
174: end-struct item%
175:
176: struct%
177: cell% 2* field type-c-name
178: cell% field type-stack \ default stack
179: cell% field type-size \ size of type in stack items
180: cell% field type-fetch \ xt of fetch code generator ( item -- )
181: cell% field type-store \ xt of store code generator ( item -- )
182: end-struct type%
183:
184: variable next-stack-number 0 next-stack-number !
185: create stacks max-stacks cells allot \ array of stacks
186:
187: : stack-in-index ( in-size item -- in-index )
188: item-offset @ - 1- ;
189:
190: : inst-in-index ( in-size item -- in-index )
191: nip dup item-offset @ swap item-type @ type-size @ + 1- ;
192:
193: : make-stack ( addr-ptr u1 type "stack-name" -- )
194: next-stack-number @ max-stacks < s" too many stacks" ?print-error
195: create stack% %allot >r
196: r@ stacks next-stack-number @ th !
197: next-stack-number @ r@ stack-number !
198: 1 next-stack-number +!
199: r@ stack-type !
200: save-mem r@ stack-pointer 2!
201: ['] stack-in-index r@ stack-in-index-xt !
202: ['] noop r@ stack-access-transform !
203: rdrop ;
204:
205: : map-stacks { xt -- }
206: \ perform xt for all stacks
207: next-stack-number @ 0 +do
208: stacks i th @ xt execute
209: loop ;
210:
211: : map-stacks1 { xt -- }
212: \ perform xt for all stacks except inst-stream
213: next-stack-number @ 1 +do
214: stacks i th @ xt execute
215: loop ;
216:
217: \ stack items
218:
219: : init-item ( addr u addr1 -- )
220: \ initialize item at addr1 with name addr u
221: \ !! remove stack prefix
222: dup item% %size erase
223: item-name 2! ;
224:
225: : map-items { addr end xt -- }
226: \ perform xt for all items in array addr...end
227: end addr ?do
228: i xt execute
229: item% %size +loop ;
230:
231: \ types
232:
233: : print-type-prefix ( type -- )
234: body> >head name>string type ;
235:
236: \ various variables for storing stuff of one primitive
237:
238: struct%
239: cell% 2* field prim-name
240: cell% 2* field prim-wordset
241: cell% 2* field prim-c-name
242: cell% 2* field prim-doc
243: cell% 2* field prim-c-code
244: cell% 2* field prim-forth-code
245: cell% 2* field prim-stack-string
246: cell% field prim-num \ ordinal number
247: cell% field prim-items-wordlist \ unique items
248: item% max-effect * field prim-effect-in
249: item% max-effect * field prim-effect-out
250: cell% field prim-effect-in-end
251: cell% field prim-effect-out-end
252: cell% max-stacks * field prim-stacks-in \ number of in items per stack
253: cell% max-stacks * field prim-stacks-out \ number of out items per stack
254: end-struct prim%
255:
256: : make-prim ( -- prim )
257: prim% %alloc { p }
258: s" " p prim-doc 2! s" " p prim-forth-code 2! s" " p prim-wordset 2!
259: p ;
260:
261: 0 value prim \ in combined prims either combined or a part
262: 0 value combined \ in combined prims the combined prim
263: variable in-part \ true if processing a part
264: in-part off
265:
266: : prim-context ( ... p xt -- ... )
267: \ execute xt with prim set to p
268: prim >r
269: swap to prim
270: catch
271: r> to prim
272: throw ;
273:
274: 1000 constant max-combined
275: create combined-prims max-combined cells allot
276: variable num-combined
277: variable part-num \ current part number during process-combined
278:
279: : map-combined { xt -- }
280: \ perform xt for all components of the current combined instruction
281: num-combined @ 0 +do
282: combined-prims i th @ xt execute
283: loop ;
284:
285: table constant combinations
286: \ the keys are the sequences of pointers to primitives
287:
288: create current-depth max-stacks cells allot
289: create max-depth max-stacks cells allot
290: create min-depth max-stacks cells allot
291:
292: create sp-update-in max-stacks cells allot
293: \ where max-depth occured the first time
294: create max-depths max-stacks max-combined 1+ * cells allot
295: \ maximum depth at start of each part: array[parts] of array[stack]
296: create max-back-depths max-stacks max-combined 1+ * cells allot
297: \ maximun depth from end of the combination to the start of the each part
298:
299: : s-c-max-depth ( nstack ncomponent -- addr )
300: max-stacks * + cells max-depths + ;
301:
302: : s-c-max-back-depth ( nstack ncomponent -- addr )
303: max-stacks * + cells max-back-depths + ;
304:
305: wordlist constant primitives
306:
307: : create-prim ( prim -- )
308: dup prim-name 2@ primitives ['] constant insert-wordlist ;
309:
310: : stack-in ( stack -- addr )
311: \ address of number of stack items in effect in
312: stack-number @ cells prim prim-stacks-in + ;
313:
314: : stack-out ( stack -- addr )
315: \ address of number of stack items in effect out
316: stack-number @ cells prim prim-stacks-out + ;
317:
318: \ global vars
319: variable c-line
320: 2variable c-filename
321: variable name-line
322: 2variable name-filename
323: 2variable last-name-filename
324: Variable function-number 0 function-number !
325:
326: \ a few more set ops
327:
328: : bit-equivalent ( w1 w2 -- w3 )
329: xor invert ;
330:
331: : complement ( set1 -- set2 )
332: empty ['] bit-equivalent binary-set-operation ;
333:
334: \ forward declaration for inst-stream (breaks cycle in definitions)
335: defer inst-stream-f ( -- stack )
336:
337: \ stack access stuff
338:
339: : normal-stack-access0 { n stack -- }
340: n stack stack-access-transform @ execute ." [" 0 .r ." ]" ;
341:
342: : normal-stack-access1 { n stack -- }
343: stack stack-pointer 2@ type
344: n if
345: n stack normal-stack-access0
346: else
347: ." TOS"
348: endif ;
349:
350: : normal-stack-access ( n stack -- )
351: dup inst-stream-f = if
352: ." IMM_ARG(" normal-stack-access1 ." ," immarg ? ." )"
353: 1 immarg +!
354: else
355: normal-stack-access1
356: endif ;
357:
358: : stack-depth { stack -- n }
359: current-depth stack stack-number @ th @ ;
360:
361: : part-stack-access { n stack -- }
362: \ print _<stack><x>, x=inst-stream? n : maxdepth-currentdepth-n-1
363: ." _" stack stack-pointer 2@ type
364: stack stack-number @ { stack# }
365: stack stack-depth n + { access-depth }
366: stack inst-stream-f = if
367: access-depth
368: else
369: combined prim-stacks-in stack# th @
370: assert( dup max-depth stack# th @ = )
371: access-depth - 1-
372: endif
373: 0 .r ;
374:
375: : part-stack-read { n stack -- }
376: stack stack-depth n + ( ndepth )
377: stack stack-number @ part-num @ s-c-max-depth @
378: \ max-depth stack stack-number @ th @ ( ndepth nmaxdepth )
379: over <= if ( ndepth ) \ load from memory
380: stack normal-stack-access
381: else
382: drop n stack part-stack-access
383: endif ;
384:
385: : stack-diff ( stack -- n )
386: \ in-out
387: dup stack-in @ swap stack-out @ - ;
388:
389: : part-stack-write { n stack -- }
390: stack stack-depth n +
391: stack stack-number @ part-num @ s-c-max-back-depth @
392: over <= if ( ndepth )
393: stack combined ['] stack-diff prim-context -
394: stack normal-stack-access
395: else
396: drop n stack part-stack-access
397: endif ;
398:
399: : stack-read ( n stack -- )
400: \ print a stack access at index n of stack
401: in-part @ if
402: part-stack-read
403: else
404: normal-stack-access
405: endif ;
406:
407: : stack-write ( n stack -- )
408: \ print a stack access at index n of stack
409: in-part @ if
410: part-stack-write
411: else
412: normal-stack-access
413: endif ;
414:
415: : item-in-index { item -- n }
416: \ n is the index of item (in the in-effect)
417: item item-stack @ dup >r stack-in @ ( in-size r:stack )
418: item r> stack-in-index-xt @ execute ;
419:
420: : item-stack-type-name ( item -- addr u )
421: item-stack @ stack-type @ type-c-name 2@ ;
422:
423: : fetch-single ( item -- )
424: \ fetch a single stack item from its stack
425: >r
426: ." vm_" r@ item-stack-type-name type
427: ." 2" r@ item-type @ print-type-prefix ." ("
428: r@ item-in-index r@ item-stack @ stack-read ." ,"
429: r@ item-name 2@ type
430: ." );" cr
431: rdrop ;
432:
433: : fetch-double ( item -- )
434: \ fetch a double stack item from its stack
435: >r
436: ." vm_two"
437: r@ item-stack-type-name type ." 2"
438: r@ item-type @ print-type-prefix ." ("
439: r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-read
440: ." , " -1 under+ ." (Cell)" stack-read
441: ." , " r@ item-name 2@ type
442: ." )" cr
443: rdrop ;
444:
445: : same-as-in? ( item -- f )
446: \ f is true iff the offset and stack of item is the same as on input
447: >r
448: r@ item-first @ if
449: rdrop false exit
450: endif
451: r@ item-name 2@ prim prim-items-wordlist @ search-wordlist 0= abort" bug"
452: execute @
453: dup r@ =
454: if \ item first appeared in output
455: drop false
456: else
457: dup item-stack @ r@ item-stack @ =
458: swap item-offset @ r@ item-offset @ = and
459: endif
460: rdrop ;
461:
462: : item-out-index ( item -- n )
463: \ n is the index of item (in the in-effect)
464: >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ;
465:
466: : really-store-single ( item -- )
467: >r
468: ." vm_"
469: r@ item-type @ print-type-prefix ." 2"
470: r@ item-stack-type-name type ." ("
471: r@ item-name 2@ type ." ,"
472: r@ item-out-index r@ item-stack @ stack-write ." );"
473: rdrop ;
474:
475: : store-single ( item -- )
476: >r
477: store-optimization @ in-part @ 0= and r@ same-as-in? and if
478: r@ item-in-index 0= r@ item-out-index 0= xor if
479: ." IF_" r@ item-stack @ stack-pointer 2@ type
480: ." TOS(" r@ really-store-single ." );" cr
481: endif
482: else
483: r@ really-store-single cr
484: endif
485: rdrop ;
486:
487: : store-double ( item -- )
488: \ !! store optimization is not performed, because it is not yet needed
489: >r
490: ." vm_"
491: r@ item-type @ print-type-prefix ." 2two"
492: r@ item-stack-type-name type ." ("
493: r@ item-name 2@ type ." , "
494: r@ item-out-index r@ item-stack @ 2dup stack-write
495: ." , " -1 under+ stack-write
496: ." )" cr
497: rdrop ;
498:
499: : single ( -- xt1 xt2 n )
500: ['] fetch-single ['] store-single 1 ;
501:
502: : double ( -- xt1 xt2 n )
503: ['] fetch-double ['] store-double 2 ;
504:
505: : s, ( addr u -- )
506: \ allocate a string
507: here swap dup allot move ;
508:
509: wordlist constant prefixes
510:
511: : declare ( addr "name" -- )
512: \ remember that there is a stack item at addr called name
513: create , ;
514:
515: : !default ( w addr -- )
516: dup @ if
517: 2drop \ leave nonzero alone
518: else
519: !
520: endif ;
521:
522: : create-type { addr u xt1 xt2 n stack -- } ( "prefix" -- )
523: \ describes a type
524: \ addr u specifies the C type name
525: \ stack effect entries of the type start with prefix
526: create type% %allot >r
527: addr u save-mem r@ type-c-name 2!
528: xt1 r@ type-fetch !
529: xt2 r@ type-store !
530: n r@ type-size !
531: stack r@ type-stack !
532: rdrop ;
533:
534: : type-prefix ( addr u xt1 xt2 n stack "prefix" -- )
535: get-current >r prefixes set-current
536: create-type r> set-current
537: does> ( item -- )
538: \ initialize item
539: { item typ }
540: typ item item-type !
541: typ type-stack @ item item-stack !default
542: item item-name 2@ prim prim-items-wordlist @ search-wordlist 0= if
543: item item-name 2@ nextname item declare
544: item item-first on
545: \ typ type-c-name 2@ type space type ." ;" cr
546: else
547: drop
548: item item-first off
549: endif ;
550:
551: : execute-prefix ( item addr1 u1 -- )
552: \ execute the word ( item -- ) associated with the longest prefix
553: \ of addr1 u1
554: 0 swap ?do
555: dup i prefixes search-wordlist
556: if \ ok, we have the type ( item addr1 xt )
557: nip execute
558: UNLOOP EXIT
559: endif
560: -1 s+loop
561: \ we did not find a type, abort
562: false s" unknown prefix" ?print-error ;
563:
564: : declaration ( item -- )
565: dup item-name 2@ execute-prefix ;
566:
567: : declaration-list ( addr1 addr2 -- )
568: ['] declaration map-items ;
569:
570: : declarations ( -- )
571: wordlist dup prim prim-items-wordlist ! set-current
572: prim prim-effect-in prim prim-effect-in-end @ declaration-list
573: prim prim-effect-out prim prim-effect-out-end @ declaration-list ;
574:
575: : print-declaration { item -- }
576: item item-first @ if
577: item item-type @ type-c-name 2@ type space
578: item item-name 2@ type ." ;" cr
579: endif ;
580:
581: : print-declarations ( -- )
582: prim prim-effect-in prim prim-effect-in-end @ ['] print-declaration map-items
583: prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ;
584:
585: : stack-prefix ( stack "prefix" -- )
586: get-current >r prefixes set-current
587: name tuck nextname create ( stack length ) 2,
588: r> set-current
589: does> ( item -- )
590: 2@ { item stack prefix-length }
591: item item-name 2@ prefix-length /string item item-name 2!
592: stack item item-stack !
593: item declaration ;
594:
595: \ types pointed to by stacks for use in combined prims
596: \ !! output-c-combined shouldn't use these names!
597: : stack-type-name ( addr u "name" -- )
598: single 0 create-type ;
599:
600: wordlist constant type-names \ this is here just to meet the requirement
601: \ that a type be a word; it is never used for lookup
602:
603: : stack ( "name" "stack-pointer" "type" -- )
604: \ define stack
605: name { d: stack-name }
606: name { d: stack-pointer }
607: name { d: stack-type }
608: get-current type-names set-current
609: stack-type 2dup nextname stack-type-name
610: set-current
611: stack-pointer lastxt >body stack-name nextname make-stack ;
612:
613: stack inst-stream IP Cell
614: ' inst-in-index inst-stream stack-in-index-xt !
615: ' inst-stream <is> inst-stream-f
616: \ !! initialize stack-in and stack-out
617:
618: \ offset computation
619: \ the leftmost (i.e. deepest) item has offset 0
620: \ the rightmost item has the highest offset
621:
622: : compute-offset { item xt -- }
623: \ xt specifies in/out; update stack-in/out and set item-offset
624: item item-type @ type-size @
625: item item-stack @ xt execute dup @ >r +!
626: r> item item-offset ! ;
627:
628: : compute-offset-in ( addr1 addr2 -- )
629: ['] stack-in compute-offset ;
630:
631: : compute-offset-out ( addr1 addr2 -- )
632: ['] stack-out compute-offset ;
633:
634: : clear-stack ( stack -- )
635: dup stack-in off stack-out off ;
636:
637: : compute-offsets ( -- )
638: ['] clear-stack map-stacks
639: prim prim-effect-in prim prim-effect-in-end @ ['] compute-offset-in map-items
640: prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items
641: inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;
642:
643: : process-simple ( -- )
644: prim prim { W^ key } key cell
645: combinations ['] constant insert-wordlist
646: declarations compute-offsets
647: output @ execute ;
648:
649: : flush-a-tos { stack -- }
650: stack stack-out @ 0<> stack stack-in @ 0= and
651: if
652: ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
653: 2dup type 0 stack normal-stack-access0 ." = " type ." TOS);" cr
654: endif ;
655:
656: : flush-tos ( -- )
657: ['] flush-a-tos map-stacks1 ;
658:
659: : fill-a-tos { stack -- }
660: stack stack-out @ 0= stack stack-in @ 0<> and
661: if
662: ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
663: 2dup type ." TOS = " type 0 stack normal-stack-access0 ." );" cr
664: endif ;
665:
666: : fill-tos ( -- )
667: \ !! inst-stream for prefetching?
668: ['] fill-a-tos map-stacks1 ;
669:
670: : fetch ( addr -- )
671: dup item-type @ type-fetch @ execute ;
672:
673: : fetches ( -- )
674: prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ;
675:
676: : stack-update-transform ( n1 stack -- n2 )
677: \ n2 is the number by which the stack pointer should be
678: \ incremented to pop n1 items
679: stack-access-transform @ dup >r execute
680: 0 r> execute - ;
681:
682: : stack-pointer-update { stack -- }
683: \ stacks grow downwards
684: stack stack-diff
685: ?dup-if \ this check is not necessary, gcc would do this for us
686: stack inst-stream = if
687: ." INC_IP(" 0 .r ." );" cr
688: else
689: stack stack-pointer 2@ type ." += "
690: stack stack-update-transform 0 .r ." ;" cr
691: endif
692: endif ;
693:
694: : stack-pointer-updates ( -- )
695: ['] stack-pointer-update map-stacks ;
696:
697: : store ( item -- )
698: \ f is true if the item should be stored
699: \ f is false if the store is probably not necessary
700: dup item-type @ type-store @ execute ;
701:
702: : stores ( -- )
703: prim prim-effect-out prim prim-effect-out-end @ ['] store map-items ;
704:
705: : print-debug-arg { item -- }
706: ." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); "
707: ." printarg_" item item-type @ print-type-prefix
708: ." (" item item-name 2@ type ." );" cr ;
709:
710: : print-debug-args ( -- )
711: ." #ifdef VM_DEBUG" cr
712: ." if (vm_debug) {" cr
713: prim prim-effect-in prim prim-effect-in-end @ ['] print-debug-arg map-items
714: \ ." fputc('\n', vm_out);" cr
715: ." }" cr
716: ." #endif" cr ;
717:
718: : print-debug-result { item -- }
719: item item-first @ if
720: item print-debug-arg
721: endif ;
722:
723: : print-debug-results ( -- )
724: cr
725: ." #ifdef VM_DEBUG" cr
726: ." if (vm_debug) {" cr
727: ." fputs(" quote ." -- " quote ." , vm_out); "
728: prim prim-effect-out prim prim-effect-out-end @ ['] print-debug-result map-items
729: ." fputc('\n', vm_out);" cr
730: ." }" cr
731: ." #endif" cr ;
732:
733: : output-super-end ( -- )
734: prim prim-c-code 2@ s" SET_IP" search if
735: ." SUPER_END;" cr
736: endif
737: 2drop ;
738:
739: : output-nextp2 ( -- )
740: ." NEXT_P2;" cr ;
741:
742: variable tail-nextp2 \ xt to execute for printing NEXT_P2 in INST_TAIL
743: ' output-nextp2 tail-nextp2 !
744:
745: : output-label2 ( -- )
746: ." LABEL2(" prim prim-c-name 2@ type ." )" cr
747: ." NEXT_P2;" cr ;
748:
749: : output-c-tail1 { xt -- }
750: \ the final part of the generated C code, with xt printing LABEL2 or not.
751: output-super-end
752: print-debug-results
753: ." NEXT_P1;" cr
754: stores
755: fill-tos
756: xt execute ;
757:
758: : output-c-tail1-no-stores { xt -- }
759: \ the final part of the generated C code for combinations
760: output-super-end
761: ." NEXT_P1;" cr
762: fill-tos
763: xt execute ;
764:
765: : output-c-tail ( -- )
766: tail-nextp2 @ output-c-tail1 ;
767:
768: : output-c-tail2 ( -- )
769: ['] output-label2 output-c-tail1 ;
770:
771: : output-c-tail-no-stores ( -- )
772: tail-nextp2 @ output-c-tail1-no-stores ;
773:
774: : output-c-tail2-no-stores ( -- )
775: ['] output-label2 output-c-tail1-no-stores ;
776:
777: : type-c-code ( c-addr u xt -- )
778: \ like TYPE, but replaces "INST_TAIL;" with tail code produced by xt
779: { xt }
780: ." {" cr
781: ." #line " c-line @ . quote c-filename 2@ type quote cr
782: begin ( c-addr1 u1 )
783: 2dup s" INST_TAIL;" search
784: while ( c-addr1 u1 c-addr3 u3 )
785: 2dup 2>r drop nip over - type
786: xt execute
787: 2r> 10 /string
788: \ !! resync #line missing
789: repeat
790: 2drop type
791: ." #line " out-nls @ 2 + . quote out-filename 2@ type quote cr
792: ." }" cr ;
793:
794: : print-entry ( -- )
795: ." LABEL(" prim prim-c-name 2@ type ." )" ;
796:
797: : output-c ( -- )
798: print-entry ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr
799: ." /* " prim prim-doc 2@ type ." */" cr
800: ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging
801: ." {" cr
802: ." DEF_CA" cr
803: print-declarations
804: ." NEXT_P0;" cr
805: flush-tos
806: fetches
807: print-debug-args
808: stack-pointer-updates
809: prim prim-c-code 2@ ['] output-c-tail type-c-code
810: output-c-tail2
811: ." }" cr
812: cr
813: ;
814:
815: : disasm-arg { item -- }
816: item item-stack @ inst-stream = if
817: ." {" cr
818: item print-declaration
819: item fetch
820: item print-debug-arg
821: ." }" cr
822: endif ;
823:
824: : disasm-args ( -- )
825: prim prim-effect-in prim prim-effect-in-end @ ['] disasm-arg map-items ;
826:
827: : output-disasm ( -- )
828: \ generate code for disassembling VM instructions
829: ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
830: ." fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr
831: disasm-args
832: ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
833: ." goto _endif_;" cr
834: ." }" cr ;
835:
836: : output-profile ( -- )
837: \ generate code for postprocessing the VM block profile stuff
838: ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
839: ." add_inst(b, " quote prim prim-name 2@ type quote ." );" cr
840: ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
841: prim prim-c-code 2@ s" SET_IP" search nip nip
842: prim prim-c-code 2@ s" SUPER_END" search nip nip or if
843: ." return;" cr
844: else
845: ." goto _endif_;" cr
846: endif
847: ." }" cr ;
848:
849: : output-profile-part ( p )
850: ." add_inst(b, " quote
851: prim-name 2@ type
852: quote ." );" cr ;
853:
854: : output-profile-combined ( -- )
855: \ generate code for postprocessing the VM block profile stuff
856: ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
857: ['] output-profile-part map-combined
858: ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
859: combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SET_IP" search nip nip
860: combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SUPER_END" search nip nip or if
861: ." return;" cr
862: else
863: ." goto _endif_;" cr
864: endif
865: ." }" cr ;
866:
867: : output-superend ( -- )
868: \ output flag specifying whether the current word ends a dynamic superinst
869: prim prim-c-code 2@ s" SET_IP" search nip nip
870: prim prim-c-code 2@ s" SUPER_END" search nip nip or 0<>
871: prim prim-c-code 2@ s" SUPER_CONTINUE" search nip nip 0= and
872: negate 0 .r ." , /* " prim prim-name 2@ type ." */" cr ;
873:
874: : gen-arg-parm { item -- }
875: item item-stack @ inst-stream = if
876: ." , " item item-type @ type-c-name 2@ type space
877: item item-name 2@ type
878: endif ;
879:
880: : gen-args-parm ( -- )
881: prim prim-effect-in prim prim-effect-in-end @ ['] gen-arg-parm map-items ;
882:
883: : gen-arg-gen { item -- }
884: item item-stack @ inst-stream = if
885: ." genarg_" item item-type @ print-type-prefix
886: ." (ctp, " item item-name 2@ type ." );" cr
887: endif ;
888:
889: : gen-args-gen ( -- )
890: prim prim-effect-in prim prim-effect-in-end @ ['] gen-arg-gen map-items ;
891:
892: : output-gen ( -- )
893: \ generate C code for generating VM instructions
894: ." void gen_" prim prim-c-name 2@ type ." (Inst **ctp" gen-args-parm ." )" cr
895: ." {" cr
896: ." gen_inst(ctp, vm_prim[" function-number @ 0 .r ." ]);" cr
897: gen-args-gen
898: ." }" cr ;
899:
900: : stack-used? { stack -- f }
901: stack stack-in @ stack stack-out @ or 0<> ;
902:
903: : output-funclabel ( -- )
904: ." &I_" prim prim-c-name 2@ type ." ," cr ;
905:
906: : output-forthname ( -- )
907: '" emit prim prim-name 2@ type '" emit ." ," cr ;
908:
909: \ : output-c-func ( -- )
910: \ \ used for word libraries
911: \ ." Cell * I_" prim prim-c-name 2@ type ." (Cell *SP, Cell **FP) /* " prim prim-name 2@ type
912: \ ." ( " prim prim-stack-string 2@ type ." ) */" cr
913: \ ." /* " prim prim-doc 2@ type ." */" cr
914: \ ." NAME(" quote prim prim-name 2@ type quote ." )" cr
915: \ \ debugging
916: \ ." {" cr
917: \ print-declarations
918: \ \ !! don't know what to do about that
919: \ inst-stream stack-used? IF ." Cell *ip=IP;" cr THEN
920: \ data-stack stack-used? IF ." Cell *sp=SP;" cr THEN
921: \ fp-stack stack-used? IF ." Cell *fp=*FP;" cr THEN
922: \ return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN
923: \ flush-tos
924: \ fetches
925: \ stack-pointer-updates
926: \ fp-stack stack-used? IF ." *FP=fp;" cr THEN
927: \ ." {" cr
928: \ ." #line " c-line @ . quote c-filename 2@ type quote cr
929: \ prim prim-c-code 2@ type
930: \ ." }" cr
931: \ stores
932: \ fill-tos
933: \ ." return (sp);" cr
934: \ ." }" cr
935: \ cr ;
936:
937: : output-label ( -- )
938: ." INST_ADDR(" prim prim-c-name 2@ type ." )," cr ;
939:
940: : output-alias ( -- )
941: ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ;
942:
943: : output-c-prim-num ( -- )
944: ." #define N_" prim prim-c-name 2@ type prim prim-num @ 8 + 4 .r cr ;
945:
946: : output-forth ( -- )
947: prim prim-forth-code @ 0=
948: IF \ output-alias
949: \ this is bad for ec: an alias is compiled if tho word does not exist!
950: \ JAW
951: ELSE ." : " prim prim-name 2@ type ." ( "
952: prim prim-stack-string 2@ type ." )" cr
953: prim prim-forth-code 2@ type cr
954: THEN ;
955:
956: : output-tag-file ( -- )
957: name-filename 2@ last-name-filename 2@ compare if
958: name-filename 2@ last-name-filename 2!
959: #ff emit cr
960: name-filename 2@ type
961: ." ,0" cr
962: endif ;
963:
964: : output-tag ( -- )
965: output-tag-file
966: prim prim-name 2@ 1+ type
967: 127 emit
968: space prim prim-name 2@ type space
969: 1 emit
970: name-line @ 0 .r
971: ." ,0" cr ;
972:
973: : output-vi-tag ( -- )
974: name-filename 2@ type #tab emit
975: prim prim-name 2@ type #tab emit
976: ." /^" prim prim-name 2@ type ." *(/" cr ;
977:
978: [IFDEF] documentation
979: : register-doc ( -- )
980: prim prim-name 2@ documentation ['] create insert-wordlist
981: prim prim-name 2@ 2,
982: prim prim-stack-string 2@ condition-stack-effect 2,
983: prim prim-wordset 2@ 2,
984: prim prim-c-name 2@ condition-pronounciation 2,
985: prim prim-doc 2@ 2, ;
986: [THEN]
987:
988:
989: \ combining instructions
990:
991: \ The input should look like this:
992:
993: \ lit_+ = lit +
994:
995: \ The output should look like this:
996:
997: \ I_lit_+:
998: \ {
999: \ DEF_CA
1000: \ Cell _x_ip0;
1001: \ Cell _x_sp0;
1002: \ Cell _x_sp1;
1003: \ NEXT_P0;
1004: \ _x_ip0 = (Cell) IPTOS;
1005: \ _x_sp0 = (Cell) spTOS;
1006: \ INC_IP(1);
1007: \ /* sp += 0; */
1008: \ /* lit ( #w -- w ) */
1009: \ /* */
1010: \ NAME("lit")
1011: \ {
1012: \ Cell w;
1013: \ w = (Cell) _x_ip0;
1014: \ #ifdef VM_DEBUG
1015: \ if (vm_debug) {
1016: \ fputs(" w=", vm_out); printarg_w (w);
1017: \ fputc('\n', vm_out);
1018: \ }
1019: \ #endif
1020: \ {
1021: \ #line 136 "./prim"
1022: \ }
1023: \ _x_sp1 = (Cell)w;
1024: \ }
1025: \ I_plus: /* + ( n1 n2 -- n ) */
1026: \ /* */
1027: \ NAME("+")
1028: \ {
1029: \ DEF_CA
1030: \ Cell n1;
1031: \ Cell n2;
1032: \ Cell n;
1033: \ NEXT_P0;
1034: \ n1 = (Cell) _x_sp0;
1035: \ n2 = (Cell) _x_sp1;
1036: \ #ifdef VM_DEBUG
1037: \ if (vm_debug) {
1038: \ fputs(" n1=", vm_out); printarg_n (n1);
1039: \ fputs(" n2=", vm_out); printarg_n (n2);
1040: \ fputc('\n', vm_out);
1041: \ }
1042: \ #endif
1043: \ {
1044: \ #line 516 "./prim"
1045: \ n = n1+n2;
1046: \ }
1047: \ _x_sp0 = (Cell)n;
1048: \ }
1049: \ NEXT_P1;
1050: \ spTOS = (Cell)_x_sp0;
1051: \ NEXT_P2;
1052:
1053: : init-combined ( -- )
1054: prim to combined
1055: 0 num-combined !
1056: current-depth max-stacks cells erase
1057: include-skipped-insts @ current-depth 0 th !
1058: max-depth max-stacks cells erase
1059: min-depth max-stacks cells erase
1060: prim prim-effect-in prim prim-effect-in-end !
1061: prim prim-effect-out prim prim-effect-out-end ! ;
1062:
1063: : max! ( n addr -- )
1064: tuck @ max swap ! ;
1065:
1066: : min! ( n addr -- )
1067: tuck @ min swap ! ;
1068:
1069: : inst-stream-adjustment ( nstack -- n )
1070: \ number of stack items to add for each part
1071: 0= include-skipped-insts @ and negate ;
1072:
1073: : add-depths { p -- }
1074: \ combine stack effect of p with *-depths
1075: max-stacks 0 ?do
1076: current-depth i th @
1077: p prim-stacks-in i th @ + i inst-stream-adjustment +
1078: dup max-depth i th max!
1079: p prim-stacks-out i th @ -
1080: dup min-depth i th min!
1081: current-depth i th !
1082: loop ;
1083:
1084: : copy-maxdepths ( n -- )
1085: max-depth max-depths rot max-stacks * th max-stacks cells move ;
1086:
1087: : add-prim ( addr u -- )
1088: \ add primitive given by "addr u" to combined-prims
1089: primitives search-wordlist s" unknown primitive" ?print-error
1090: execute { p }
1091: p combined-prims num-combined @ th !
1092: num-combined @ copy-maxdepths
1093: 1 num-combined +!
1094: p add-depths
1095: num-combined @ copy-maxdepths ;
1096:
1097: : compute-effects { q -- }
1098: \ compute the stack effects of q from the depths
1099: max-stacks 0 ?do
1100: max-depth i th @ dup
1101: q prim-stacks-in i th !
1102: current-depth i th @ -
1103: q prim-stacks-out i th !
1104: loop ;
1105:
1106: : make-effect-items { stack# items effect-endp -- }
1107: \ effect-endp points to a pointer to the end of the current item-array
1108: \ and has to be updated
1109: stacks stack# th @ { stack }
1110: items 0 +do
1111: effect-endp @ { item }
1112: i 0 <# #s stack stack-pointer 2@ holds [char] _ hold #> save-mem
1113: item item-name 2!
1114: stack item item-stack !
1115: stack stack-type @ item item-type !
1116: i item item-offset !
1117: item item-first on
1118: item% %size effect-endp +!
1119: loop ;
1120:
1121: : init-effects { q -- }
1122: \ initialize effects field for FETCHES and STORES
1123: max-stacks 0 ?do
1124: i q prim-stacks-in i th @ q prim-effect-in-end make-effect-items
1125: i q prim-stacks-out i th @ q prim-effect-out-end make-effect-items
1126: loop ;
1127:
1128: : compute-stack-max-back-depths ( stack -- )
1129: stack-number @ { stack# }
1130: current-depth stack# th @ dup
1131: dup stack# num-combined @ s-c-max-back-depth !
1132: -1 num-combined @ 1- -do ( max-depth current-depth )
1133: combined-prims i th @ { p }
1134: p prim-stacks-out stack# th @ +
1135: dup >r max r>
1136: over stack# i s-c-max-back-depth !
1137: p prim-stacks-in stack# th @ -
1138: stack# inst-stream-adjustment -
1139: 1 -loop
1140: assert( dup stack# inst-stream-adjustment negate = )
1141: assert( over max-depth stack# th @ = )
1142: 2drop ;
1143:
1144: : compute-max-back-depths ( -- )
1145: \ compute max-back-depths.
1146: \ assumes that current-depths is correct for the end of the combination
1147: ['] compute-stack-max-back-depths map-stacks ;
1148:
1149: : process-combined ( -- )
1150: combined combined-prims num-combined @ cells
1151: combinations ['] constant insert-wordlist
1152: combined-prims num-combined @ 1- th ( last-part )
1153: @ prim-c-code 2@ prim prim-c-code 2! \ used by output-super-end
1154: prim compute-effects
1155: prim init-effects
1156: compute-max-back-depths
1157: output-combined perform ;
1158:
1159: \ C output
1160:
1161: : print-item { n stack -- }
1162: \ print nth stack item name
1163: stack stack-type @ type-c-name 2@ type space
1164: ." _" stack stack-pointer 2@ type n 0 .r ;
1165:
1166: : print-declarations-combined ( -- )
1167: max-stacks 0 ?do
1168: max-depth i th @ min-depth i th @ - 0 +do
1169: i stacks j th @ print-item ." ;" cr
1170: loop
1171: loop ;
1172:
1173: : part-fetches ( -- )
1174: fetches ;
1175:
1176: : part-output-c-tail ( -- )
1177: print-debug-results
1178: stores ;
1179:
1180: : output-combined-tail ( -- )
1181: part-output-c-tail
1182: in-part @ >r in-part off
1183: combined ['] output-c-tail-no-stores prim-context
1184: r> in-part ! ;
1185:
1186: : part-stack-pointer-updates ( -- )
1187: next-stack-number @ 0 +do
1188: i part-num @ 1+ s-c-max-depth @ dup
1189: i num-combined @ s-c-max-depth @ = \ final depth
1190: swap i part-num @ s-c-max-depth @ <> \ just reached now
1191: part-num @ 0= \ first part
1192: or and if
1193: stacks i th @ stack-pointer-update
1194: endif
1195: loop ;
1196:
1197: : output-part ( p -- )
1198: to prim
1199: ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr
1200: ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging
1201: ." {" cr
1202: print-declarations
1203: part-fetches
1204: print-debug-args
1205: combined ['] part-stack-pointer-updates prim-context
1206: 1 part-num +!
1207: prim add-depths \ !! right place?
1208: prim prim-c-code 2@ ['] output-combined-tail type-c-code
1209: part-output-c-tail
1210: ." }" cr ;
1211:
1212: : output-parts ( -- )
1213: prim >r in-part on
1214: current-depth max-stacks cells erase
1215: 0 part-num !
1216: ['] output-part map-combined
1217: in-part off
1218: r> to prim ;
1219:
1220: : output-c-combined ( -- )
1221: print-entry cr
1222: \ debugging messages just in parts
1223: ." {" cr
1224: ." DEF_CA" cr
1225: print-declarations-combined
1226: ." NEXT_P0;" cr
1227: flush-tos
1228: \ fetches \ now in parts
1229: \ print-debug-args
1230: \ stack-pointer-updates now in parts
1231: output-parts
1232: output-c-tail2-no-stores
1233: ." }" cr
1234: cr ;
1235:
1236: : output-forth-combined ( -- )
1237: ;
1238:
1239:
1240: \ peephole optimization rules
1241:
1242: \ data for a simple peephole optimizer that always tries to combine
1243: \ the currently compiled instruction with the last one.
1244:
1245: \ in order for this to work as intended, shorter combinations for each
1246: \ length must be present, and the longer combinations must follow
1247: \ shorter ones (this restriction may go away in the future).
1248:
1249: : output-peephole ( -- )
1250: combined-prims num-combined @ 1- cells combinations search-wordlist
1251: s" the prefix for this superinstruction must be defined earlier" ?print-error
1252: ." {"
1253: execute prim-num @ 5 .r ." ,"
1254: combined-prims num-combined @ 1- th @ prim-num @ 5 .r ." ,"
1255: combined prim-num @ 5 .r ." }, /* "
1256: combined prim-c-name 2@ type ." */"
1257: cr ;
1258:
1259:
1260: \ cost and superinstruction data for a sophisticated combiner (e.g.,
1261: \ shortest path)
1262:
1263: \ This is intended as initializer for a structure like this
1264:
1265: \ struct cost {
1266: \ int loads; /* number of stack loads */
1267: \ int stores; /* number of stack stores */
1268: \ int updates; /* number of stack pointer updates */
1269: \ int length; /* number of components */
1270: \ int *components; /* array of vm_prim indexes of components */
1271: \ };
1272:
1273: \ How do you know which primitive or combined instruction this
1274: \ structure refers to? By the order of cost structures, as in most
1275: \ other cases.
1276:
1277: : compute-costs { p -- nloads nstores nupdates }
1278: \ compute the number of loads, stores, and stack pointer updates
1279: \ of a primitive or combined instruction; does not take TOS
1280: \ caching into account, nor that IP updates are combined with
1281: \ other stuff
1282: 0 max-stacks 0 +do
1283: p prim-stacks-in i th @ +
1284: loop
1285: 0 max-stacks 0 +do
1286: p prim-stacks-out i th @ +
1287: loop
1288: 0 max-stacks 0 +do
1289: p prim-stacks-in i th @ p prim-stacks-out i th @ <> -
1290: loop ;
1291:
1292: : output-num-part ( p -- )
1293: prim-num @ 4 .r ." ," ;
1294:
1295: : output-costs ( -- )
1296: ." {" prim compute-costs
1297: rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ,"
1298: combined if
1299: num-combined @ 2 .r
1300: ." , ((int []){" ['] output-num-part map-combined ." })}, /* "
1301: else
1302: ." 1, ((int []){" prim prim-num @ 4 .r ." })}, /* "
1303: endif
1304: prim prim-name 2@ type ." */"
1305: cr ;
1306:
1307: \ the parser
1308:
1309: eof-char max-member \ the whole character set + EOF
1310:
1311: : getinput ( -- n )
1312: rawinput @ endrawinput @ =
1313: if
1314: eof-char
1315: else
1316: cookedinput @ c@
1317: endif ;
1318:
1319: :noname ( n -- )
1320: dup bl > if
1321: emit space
1322: else
1323: .
1324: endif ;
1325: print-token !
1326:
1327: : testchar? ( set -- f )
1328: getinput member? ;
1329: ' testchar? test-vector !
1330:
1331: : checksynclines ( -- )
1332: \ when input points to a newline, check if the next line is a
1333: \ sync line. If it is, perform the appropriate actions.
1334: begin
1335: rawinput @ >r
1336: s" #line " r@ over compare if
1337: rdrop 1 line +! EXIT
1338: endif
1339: 0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )
1340: dup c@ bl = if
1341: char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error
1342: char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2!
1343: char+
1344: endif
1345: dup c@ nl-char <> 0= s" sync line syntax" ?print-error
1346: skipsynclines @ if
1347: dup char+ rawinput !
1348: rawinput @ c@ cookedinput @ c!
1349: endif
1350: drop
1351: again ;
1352:
1353: : ?nextchar ( f -- )
1354: s" syntax error, wrong char" ?print-error
1355: rawinput @ endrawinput @ <> if
1356: rawinput @ c@
1357: 1 chars rawinput +!
1358: 1 chars cookedinput +!
1359: nl-char = if
1360: checksynclines
1361: rawinput @ line-start !
1362: endif
1363: rawinput @ c@
1364: cookedinput @ c!
1365: endif ;
1366:
1367: : charclass ( set "name" -- )
1368: ['] ?nextchar terminal ;
1369:
1370: : .. ( c1 c2 -- set )
1371: ( creates a set that includes the characters c, c1<=c<=c2 )
1372: empty copy-set
1373: swap 1+ rot do
1374: i over add-member
1375: loop ;
1376:
1377: : ` ( -- terminal ) ( use: ` c )
1378: ( creates anonymous terminal for the character c )
1379: char singleton ['] ?nextchar make-terminal ;
1380:
1381: char a char z .. char A char Z .. union char _ singleton union charclass letter
1382: char 0 char 9 .. charclass digit
1383: bl singleton tab-char over add-member charclass white
1384: nl-char singleton eof-char over add-member complement charclass nonl
1385: nl-char singleton eof-char over add-member
1386: char : over add-member complement charclass nocolonnl
1387: nl-char singleton eof-char over add-member
1388: char } over add-member complement charclass nobracenl
1389: bl 1+ maxchar .. char \ singleton complement intersection
1390: charclass nowhitebq
1391: bl 1+ maxchar .. charclass nowhite
1392: char " singleton eof-char over add-member complement charclass noquote
1393: nl-char singleton charclass nl
1394: eof-char singleton charclass eof
1395: nl-char singleton eof-char over add-member charclass nleof
1396:
1397: (( letter (( letter || digit )) **
1398: )) <- c-ident ( -- )
1399:
1400: (( ` # ?? (( letter || digit || ` : )) ++
1401: )) <- stack-ident ( -- )
1402:
1403: (( nowhitebq nowhite ** ))
1404: <- forth-ident ( -- )
1405:
1406: Variable forth-flag
1407: Variable c-flag
1408:
1409: (( (( ` e || ` E )) {{ start }} nonl **
1410: {{ end evaluate }}
1411: )) <- eval-comment ( ... -- ... )
1412:
1413: (( (( ` f || ` F )) {{ start }} nonl **
1414: {{ end forth-flag @ IF type cr ELSE 2drop THEN }}
1415: )) <- forth-comment ( -- )
1416:
1417: (( (( ` c || ` C )) {{ start }} nonl **
1418: {{ end c-flag @ IF type cr ELSE 2drop THEN }}
1419: )) <- c-comment ( -- )
1420:
1421: (( ` - nonl ** {{
1422: forth-flag @ IF ." [ELSE]" cr THEN
1423: c-flag @ IF ." #else" cr THEN }}
1424: )) <- else-comment
1425:
1426: (( ` + {{ start }} nonl ** {{ end
1427: dup
1428: IF c-flag @
1429: IF ." #ifdef HAS_" bounds ?DO I c@ toupper emit LOOP cr
1430: THEN
1431: forth-flag @
1432: IF ." has? " type ." [IF]" cr THEN
1433: ELSE 2drop
1434: c-flag @ IF ." #endif" cr THEN
1435: forth-flag @ IF ." [THEN]" cr THEN
1436: THEN }}
1437: )) <- if-comment
1438:
1439: (( (( ` g || ` G )) {{ start }} nonl **
1440: {{ end
1441: forth-flag @ IF ." group " type cr THEN
1442: c-flag @ IF ." GROUP(" type ." , " function-number @ 0 .r ." )" cr THEN }}
1443: )) <- group-comment
1444:
1445: (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body
1446:
1447: (( ` \ comment-body nleof )) <- comment ( -- )
1448:
1449: (( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) **
1450: <- stack-items
1451:
1452: (( {{ prim prim-effect-in }} stack-items {{ prim prim-effect-in-end ! }}
1453: ` - ` - white **
1454: {{ prim prim-effect-out }} stack-items {{ prim prim-effect-out-end ! }}
1455: )) <- stack-effect ( -- )
1456:
1457: (( {{ prim create-prim }}
1458: ` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white **
1459: (( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white **
1460: (( {{ start }} c-ident {{ end prim prim-c-name 2! }} )) ??
1461: )) ?? nleof
1462: (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ??
1463: {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }}
1464: (( (( ` { nonl ** nleof (( (( nobracenl {{ line @ drop }} nonl ** )) ?? nleof )) ** ` } white ** nleof white ** ))
1465: || (( nocolonnl nonl ** nleof white ** )) ** ))
1466: {{ end prim prim-c-code 2! skipsynclines on }}
1467: (( ` : white ** nleof
1468: {{ start }} (( nonl ++ nleof white ** )) ++ {{ end prim prim-forth-code 2! }}
1469: )) ?? {{ process-simple }}
1470: nleof
1471: )) <- simple-primitive ( -- )
1472:
1473: (( {{ init-combined }}
1474: ` = white ** (( {{ start }} forth-ident {{ end add-prim }} white ** )) ++
1475: nleof {{ process-combined }}
1476: )) <- combined-primitive
1477:
1478: (( {{ make-prim to prim 0 to combined
1479: line @ name-line ! filename 2@ name-filename 2!
1480: function-number @ prim prim-num !
1481: start }} [ifdef] vmgen c-ident [else] forth-ident [then] {{ end
1482: 2dup prim prim-name 2! prim prim-c-name 2! }} white **
1483: (( ` / white ** {{ start }} c-ident {{ end prim prim-c-name 2! }} white ** )) ??
1484: (( simple-primitive || combined-primitive )) {{ 1 function-number +! }}
1485: )) <- primitive ( -- )
1486:
1487: (( (( comment || primitive || nl white ** )) ** eof ))
1488: parser primitives2something
1489: warnings @ [IF]
1490: .( parser generated ok ) cr
1491: [THEN]
1492:
1493:
1494: \ run with gforth-0.5.0 (slurp-file is missing)
1495: [IFUNDEF] slurp-file
1496: : slurp-file ( c-addr1 u1 -- c-addr2 u2 )
1497: \ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents
1498: r/o bin open-file throw >r
1499: r@ file-size throw abort" file too large"
1500: dup allocate throw swap
1501: 2dup r@ read-file throw over <> abort" could not read whole file"
1502: r> close-file throw ;
1503: [THEN]
1504:
1505: : primfilter ( addr u -- )
1506: \ process the string at addr u
1507: over dup rawinput ! dup line-start ! cookedinput !
1508: + endrawinput !
1509: checksynclines
1510: primitives2something ;
1511:
1512: : unixify ( c-addr u1 -- c-addr u2 )
1513: \ delete crs from the string
1514: bounds tuck tuck ?do ( c-addr1 )
1515: i c@ dup #cr <> if
1516: over c! char+
1517: else
1518: drop
1519: endif
1520: loop
1521: over - ;
1522:
1523: : process-file ( addr u xt-simple x-combined -- )
1524: output-combined ! output !
1525: save-mem 2dup filename 2!
1526: slurp-file unixify
1527: warnings @ if
1528: ." ------------ CUT HERE -------------" cr endif
1529: primfilter ;
1530:
1531: \ : process ( xt -- )
1532: \ bl word count rot
1533: \ process-file ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>