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