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