File:  [gforth] / gforth / prims2x.fs
Revision 1.39: download - view: text, annotated - select for diffs
Tue Mar 2 15:45:32 1999 UTC (20 years, 7 months ago) by jwilke
Branches: MAIN
CVS tags: HEAD
Changes in file including.

    1: \ converts primitives to, e.g., C code 
    2: 
    3: \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation; either version 2
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program; if not, write to the Free Software
   19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   20: 
   21: 
   22: \ This is not very nice (hard limits, no checking, assumes 1 chars = 1)
   23: 
   24: \ Optimizations:
   25: \ superfluous stores are removed. GCC removes the superfluous loads by itself
   26: \ TOS and FTOS can be kept in register( variable)s.
   27: \ 
   28: \ Problems:
   29: \ The TOS optimization is somewhat hairy. The problems by example:
   30: \ 1) dup ( w -- w w ): w=TOS; sp-=1; sp[1]=w; TOS=w;
   31: \    The store is not superfluous although the earlier opt. would think so
   32: \    Alternatively:    sp[0]=TOS; w=TOS; sp-=1; TOS=w;
   33: \ 2) ( -- .. ): sp[0] = TOS; ... /* This additional store is necessary */
   34: \ 3) ( .. -- ): ... TOS = sp[0]; /* as well as this load */
   35: \ 4) ( -- ): /* but here they are unnecessary */
   36: \ 5) Words that call NEXT themselves have to be done very carefully.
   37: \
   38: \ To do:
   39: \ add the store optimization for doubles
   40: \ regarding problem 1 above: It would be better (for over) to implement
   41: \ 	the alternative
   42: 
   43: warnings off
   44: 
   45: [IFUNDEF] vocabulary	\ 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]
   53: 
   54: include ./gray.fs
   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
   59: #tab constant tab-char
   60: #lf constant nl-char
   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
   65:   >r dup $7fffffff r> read-file throw + ;
   66: 
   67: variable rawinput \ pointer to next character to be scanned
   68: variable endrawinput \ pointer to the end of the input (the char after the last)
   69: variable cookedinput \ pointer to the next char to be parsed
   70: variable line \ line number of char pointed to by input
   71: 1 line !
   72: 2variable filename \ filename of original input file
   73: 0 0 filename 2!
   74: 2variable f-comment
   75: 0 0 f-comment 2!
   76: variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?
   77: skipsynclines on 
   78: 
   79: Variable flush-comment flush-comment off
   80: 
   81: : ?flush-comment
   82:     flush-comment @ 0= ?EXIT
   83:     f-comment 2@ nip
   84:     IF  cr f-comment 2@ 2 /string 1-
   85: 	dup IF
   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
   96: 	ELSE    flush-comment @ 1 = IF  ." #endif"  ELSE  ." [THEN]"  THEN
   97: 	    cr  THEN
   98: 	0 0 f-comment 2! THEN ;
   99: 
  100: : start ( -- addr )
  101:  cookedinput @ ;
  102: 
  103: : end ( addr -- addr u )
  104:  cookedinput @ over - ;
  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
  141: variable c-line
  142: 2variable c-filename
  143: variable name-line
  144: 2variable name-filename
  145: 2variable last-name-filename
  146: 
  147: variable primitive-number -10 primitive-number !
  148: Variable function-number 0 function-number !
  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 )
  168:  rawinput @ endrawinput @ =
  169:  if
  170:    eof-char
  171:  else
  172:    cookedinput @ c@
  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: 
  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.
  190:     rawinput @ >r
  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"
  197: 	char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2!
  198: 	char+
  199:     endif
  200:     dup c@ nl-char <> abort" sync line syntax"
  201:     skipsynclines @ if
  202: 	dup char+ rawinput !
  203: 	rawinput @ c@ cookedinput @ c!
  204:     endif
  205:     drop ;
  206: 
  207: : ?nextchar ( f -- )
  208:     ?not? if
  209: 	filename 2@ type ." :" line @ 0 .r ." : syntax error, wrong char:"
  210: 	getinput . cr
  211: 	rawinput @ endrawinput @ over - 100 min type cr
  212: 	abort
  213:     endif
  214:     rawinput @ endrawinput @ <> if
  215: 	rawinput @ c@
  216: 	1 chars rawinput +!
  217: 	1 chars cookedinput +!
  218: 	nl-char = if
  219: 	    checksyncline
  220: 	endif
  221: 	rawinput @ c@ cookedinput @ c!
  222:     endif ;
  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 )
  236:  char singleton ['] ?nextchar make-terminal ;
  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: 
  256: (( {{ ?flush-comment start }} ` \ nonl ** nl {{ end
  257:       2dup 2 min s" \+" compare 0= IF  f-comment 2!  ELSE  2drop  THEN }}
  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 )) **
  267:    (( {{ line @ name-line ! filename 2@ name-filename 2! }}
  268:       {{ start }} name {{ end 2dup forth-name 2! c-name 2! }}  tab ++
  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 )) ??
  274:    {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl **  nl )) ** {{ end c-code 2! skipsynclines on }}
  275:    (( ` :  nl
  276:       {{ start }} (( nonl ++  nl )) ++ {{ end forth-code 2! }}
  277:    )) ??
  278:    (( nl || eof ))
  279: )) <- primitive ( -- )
  280: 
  281: (( (( primitive {{ printprim }} )) ** eof ))
  282: parser primitives2something
  283: warnings @ [IF]
  284: .( parser generated ok ) cr
  285: [THEN]
  286: 
  287: : primfilter ( file-id xt -- )
  288: \ fileid is for the input file, xt ( -- ) is for the output word
  289:  output !
  290:  here dup rawinput ! cookedinput !
  291:  here swap read-whole-file
  292:  dup endrawinput !
  293:  here - allot
  294:  align
  295:  checksyncline
  296: \ begin
  297: \     getinput dup eof-char = ?EXIT emit true ?nextchar
  298: \ again ;
  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
  315:    ." sp[" 0 .r ." ]"
  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
  324:    ." fp[" 0 .r ." ]"
  325:  else
  326:    drop ." FTOS"
  327:  endif ;
  328: 
  329: : fetch-single ( item -- )
  330:  >r
  331:  r@ item-name 2@ type
  332:  ."  = (" 
  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
  339:  ." FETCH_DCELL("
  340:  r@ item-name 2@ type ." , "
  341:  r@ item-d-offset @ dup    effect-in-size 2@ data-stack-access
  342:  ." , "			1+ effect-in-size 2@ data-stack-access
  343:  ." );" cr
  344:  rdrop ;
  345: 
  346: : fetch-float ( item -- )
  347:  >r
  348:  r@ item-name 2@ type
  349:  ."  = "
  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=
  358:  abort" bug"
  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: 
  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: 
  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
  386:    r@ is-in-tos? r@ is-out-tos? xor
  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
  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
  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=
  408:  abort" bug"
  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:  
  441: : single-type ( -- xt1 xt2 n1 n2 )
  442:  ['] fetch-single ['] store-single 1 0 ;
  443: 
  444: : double-type ( -- xt1 xt2 n1 n2 )
  445:  ['] fetch-double ['] store-double 2 0 ;
  446: 
  447: : float-type ( -- xt1 xt2 n1 n2 )
  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
  485: s" struct F83Name *"	single-type starts-with f83name
  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
  498:  -1 s+loop
  499:  \ we did not find a type, abort
  500:  true abort" unknown type prefix" ;
  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: 
  522: : fetch ( addr -- )
  523:  dup item-type @ type-fetch-handler execute ;
  524: 
  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
  558:    ." IF_FTOS(fp[0] = FTOS);" cr
  559:  endif
  560:  0<> swap 0= and
  561:  if
  562:    ." IF_TOS(sp[0] = TOS);" cr
  563:  endif ;
  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 ( -- )
  582: \ we need not check if an update is a noop; gcc does this for us
  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 )
  587:  ?dup IF  ." sp += " 0 .r ." ;" cr  THEN
  588:  ?dup IF  ." fp += " 0 .r ." ;" cr  THEN ;
  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: 
  600: : .stack-list ( start end -- )
  601:  swap ?do
  602:    i item-name 2@ type space
  603:  item-descr +loop ; 
  604: 
  605: : output-c ( -- ) 1 flush-comment !
  606:     ?flush-comment
  607:  ." I_" c-name 2@ type ." :	/* " forth-name 2@ type ."  ( " stack-string 2@ type ."  ) */" cr
  608:  ." /* " doc 2@ type ."  */" cr
  609:  ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging
  610:  ." {" cr
  611:  ." DEF_CA" cr
  612:  declarations
  613:  compute-offsets \ for everything else
  614:  ." NEXT_P0;" cr
  615:  flush-tos
  616:  fetches
  617:  stack-pointer-updates
  618:  ." {" cr
  619:  ." #line " c-line @ . [char] " emit c-filename 2@ type [char] " emit cr
  620:  c-code 2@ type
  621:  ." }" cr
  622:  ." NEXT_P1;" cr
  623:  stores
  624:  fill-tos
  625:  ." NEXT_P2;" cr
  626:  ." }" cr
  627:  cr
  628: ;
  629: 
  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: 
  664: : output-label ( -- )  1 flush-comment !
  665:     ?flush-comment
  666:     ." (Label)&&I_" c-name 2@ type ." ," cr
  667:     -1 primitive-number +! ;
  668: 
  669: : output-alias ( -- )  flush-comment on
  670:     ?flush-comment
  671:     ( primitive-number @ . ." alias " ) ." Primitive " forth-name 2@ type cr
  672:     -1 primitive-number +! ;
  673: 
  674: : output-forth ( -- )  flush-comment on
  675:     ?flush-comment
  676:     forth-code @ 0=
  677:     IF    	\ output-alias
  678: 	\ this is bad for ec: an alias is compiled if tho word does not exist!
  679: 	\ JAW
  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 ;
  686: 
  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: 
  704: [IFDEF] documentation
  705: : register-doc ( -- )
  706:     get-current documentation set-current
  707:     forth-name 2@ nextname create
  708:     forth-name 2@ 2,
  709:     stack-string 2@ condition-stack-effect 2,
  710:     wordset 2@ 2,
  711:     c-name 2@ condition-pronounciation 2,
  712:     doc 2@ 2,
  713:     set-current ;
  714: [THEN]
  715: 
  716: : process-file ( addr u xt -- )
  717:     >r
  718:     2dup filename 2!
  719:     0 function-number !
  720:     r/o open-file abort" cannot open file"
  721:     warnings @ if
  722: 	." ------------ CUT HERE -------------" cr  endif
  723:     r> primfilter ;
  724: 
  725: : process      ( xt -- )
  726:     bl word count rot
  727:     process-file ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>