File:  [gforth] / gforth / prims2x.fs
Revision 1.104: download - view: text, annotated - select for diffs
Sun Feb 10 14:02:25 2002 UTC (17 years, 8 months ago) by anton
Branches: MAIN
CVS tags: HEAD
lit@ and lit+ are now defined as superinstructions
compile lit @ and lit + instead of lit@ and lit+
extended prims2x to support superinstructions with non-C-names
  (syntax: forth-name /c-name = ...)
support profiling of interpreters with superinstructions
  (with simple instructions in the output).
profile output with prefixes only (enable by editing profile.c).
optional reporting of static superinstruction lengths (compared to
  dynamic superinstructions); enable by compiling with -DPRINT_SUPER_LENGTHS

    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: 
   64: include ./gray.fs
   65: 
   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 f-comment
   82: 0 0 f-comment 2!
   83: variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?
   84: skipsynclines on 
   85: 
   86: : th ( addr1 n -- addr2 )
   87:     cells + ;
   88: 
   89: : holds ( addr u -- )
   90:     \ like HOLD, but for a string
   91:     tuck + swap 0 +do
   92: 	1- dup c@ hold
   93:     loop
   94:     drop ;
   95: 
   96: : insert-wordlist { c-addr u wordlist xt -- }
   97:     \ adds name "addr u" to wordlist using defining word xt
   98:     \ xt may cause additional stack effects
   99:     get-current >r wordlist set-current
  100:     c-addr u nextname xt execute
  101:     r> set-current ;
  102: 
  103: : start ( -- addr )
  104:  cookedinput @ ;
  105: 
  106: : end ( addr -- addr u )
  107:  cookedinput @ over - ;
  108: 
  109: : print-error-line ( -- )
  110:     \ print the current line and position
  111:     line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end )
  112:     over - type cr
  113:     line-start @ rawinput @ over - typewhite ." ^" cr ;
  114: 
  115: : ?print-error { f addr u -- }
  116:     f ?not? if
  117: 	outfile-id >r try
  118: 	    stderr to outfile-id
  119: 	    filename 2@ type ." :" line @ 0 .r ." : " addr u type cr
  120: 	    print-error-line
  121: 	    0
  122: 	recover endtry
  123: 	r> to outfile-id throw
  124: 	abort
  125:     endif ;
  126: 
  127: : quote ( -- )
  128:     [char] " emit ;
  129: 
  130: variable output          \ xt ( -- ) of output word for simple primitives
  131: variable output-combined \ xt ( -- ) of output word for combined primitives
  132: 
  133: struct%
  134:     cell%    field stack-number \ the number of this stack
  135:     cell% 2* field stack-pointer \ stackpointer name
  136:     cell%    field stack-type \ name for default type of stack items
  137:     cell%    field stack-in-index-xt \ ( in-size item -- in-index )
  138: end-struct stack%
  139: 
  140: struct%
  141:  cell% 2* field item-name   \ name, excluding stack prefixes
  142:  cell%    field item-stack  \ descriptor for the stack used, 0 is default
  143:  cell%    field item-type   \ descriptor for the item type
  144:  cell%    field item-offset \ offset in stack items, 0 for the deepest element
  145:  cell%	  field item-first  \ true if this is the first occurence of the item
  146: end-struct item%
  147: 
  148: struct%
  149:     cell% 2* field type-c-name
  150:     cell%    field type-stack \ default stack
  151:     cell%    field type-size  \ size of type in stack items
  152:     cell%    field type-fetch \ xt of fetch code generator ( item -- )
  153:     cell%    field type-store \ xt of store code generator ( item -- )
  154: end-struct type%
  155: 
  156: variable next-stack-number 0 next-stack-number !
  157: create stacks max-stacks cells allot \ array of stacks
  158: 
  159: : stack-in-index ( in-size item -- in-index )
  160:     item-offset @ - 1- ;
  161: 
  162: : inst-in-index ( in-size item -- in-index )
  163:     nip dup item-offset @ swap item-type @ type-size @ + 1- ;
  164: 
  165: : make-stack ( addr-ptr u1 type "stack-name" -- )
  166:     next-stack-number @ max-stacks < s" too many stacks" ?print-error
  167:     create stack% %allot >r
  168:     r@ stacks next-stack-number @ th !
  169:     next-stack-number @ r@ stack-number !
  170:     1 next-stack-number +!
  171:     r@ stack-type !
  172:     save-mem r@ stack-pointer 2! 
  173:     ['] stack-in-index r> stack-in-index-xt ! ;
  174: 
  175: : map-stacks { xt -- }
  176:     \ perform xt for all stacks except inst-stream
  177:     next-stack-number @ 1 +do
  178: 	stacks i th @ xt execute
  179:     loop ;
  180: 
  181: \ stack items
  182: 
  183: : init-item ( addr u addr1 -- )
  184:     \ initialize item at addr1 with name addr u
  185:     \ !! remove stack prefix
  186:     dup item% %size erase
  187:     item-name 2! ;
  188: 
  189: : map-items { addr end xt -- }
  190:     \ perform xt for all items in array addr...end
  191:     end addr ?do
  192: 	i xt execute
  193:     item% %size +loop ;
  194: 
  195: \ types
  196: 
  197: : print-type-prefix ( type -- )
  198:     body> >head name>string type ;
  199: 
  200: \ various variables for storing stuff of one primitive
  201: 
  202: struct%
  203:     cell% 2* field prim-name
  204:     cell% 2* field prim-wordset
  205:     cell% 2* field prim-c-name
  206:     cell% 2* field prim-doc
  207:     cell% 2* field prim-c-code
  208:     cell% 2* field prim-forth-code
  209:     cell% 2* field prim-stack-string
  210:     cell%    field prim-num            \ ordinal number
  211:     cell%    field prim-items-wordlist \ unique items
  212:     item% max-effect * field prim-effect-in
  213:     item% max-effect * field prim-effect-out
  214:     cell%    field prim-effect-in-end
  215:     cell%    field prim-effect-out-end
  216:     cell% max-stacks * field prim-stacks-in  \ number of in items per stack
  217:     cell% max-stacks * field prim-stacks-out \ number of out items per stack
  218: end-struct prim%
  219: 
  220: : make-prim ( -- prim )
  221:     prim% %alloc { p }
  222:     s" " p prim-doc 2! s" " p prim-forth-code 2! s" " p prim-wordset 2!
  223:     p ;
  224: 
  225: 0 value prim     \ in combined prims either combined or a part
  226: 0 value combined \ in combined prims the combined prim
  227: variable in-part \ true if processing a part
  228:  in-part off
  229: 
  230: 1000 constant max-combined
  231: create combined-prims max-combined cells allot
  232: variable num-combined
  233: 
  234: table constant combinations
  235:   \ the keys are the sequences of pointers to primitives
  236: 
  237: create current-depth max-stacks cells allot
  238: create max-depth     max-stacks cells allot
  239: create min-depth     max-stacks cells allot
  240: 
  241: wordlist constant primitives
  242: 
  243: : create-prim ( prim -- )
  244:     dup prim-name 2@ primitives ['] constant insert-wordlist ;
  245: 
  246: : stack-in ( stack -- addr )
  247:     \ address of number of stack items in effect in
  248:     stack-number @ cells prim prim-stacks-in + ;
  249: 
  250: : stack-out ( stack -- addr )
  251:     \ address of number of stack items in effect out
  252:     stack-number @ cells prim prim-stacks-out + ;
  253: 
  254: \ global vars
  255: variable c-line
  256: 2variable c-filename
  257: variable name-line
  258: 2variable name-filename
  259: 2variable last-name-filename
  260: Variable function-number 0 function-number !
  261: 
  262: \ a few more set ops
  263: 
  264: : bit-equivalent ( w1 w2 -- w3 )
  265:  xor invert ;
  266: 
  267: : complement ( set1 -- set2 )
  268:  empty ['] bit-equivalent binary-set-operation ;
  269: 
  270: \ stack access stuff
  271: 
  272: : normal-stack-access ( n stack -- )
  273:     stack-pointer 2@ type
  274:     dup
  275:     if
  276: 	." [" 0 .r ." ]"
  277:     else
  278: 	drop ." TOS"
  279:     endif ;
  280: 
  281: \ forward declaration for inst-stream (breaks cycle in definitions)
  282: defer inst-stream-f ( -- stack )
  283: 
  284: : part-stack-access { n stack -- }
  285:     \ print _<stack><x>, x=inst-stream? n : maxdepth-currentdepth-n-1
  286:     ." _" stack stack-pointer 2@ type
  287:     stack stack-number @ { stack# }
  288:     current-depth stack# th @ n + { access-depth }
  289:     stack inst-stream-f = if
  290: 	access-depth
  291:     else
  292: 	combined prim-stacks-in stack# th @
  293: 	assert( dup max-depth stack# th @ = )
  294: 	access-depth - 1-
  295:     endif
  296:     0 .r ;
  297: 
  298: : stack-access ( n stack -- )
  299:     \ print a stack access at index n of stack
  300:     in-part @ if
  301: 	part-stack-access
  302:     else
  303: 	normal-stack-access
  304:     endif ;
  305: 
  306: : item-in-index { item -- n }
  307:     \ n is the index of item (in the in-effect)
  308:     item item-stack @ dup >r stack-in @ ( in-size r:stack )
  309:     item r> stack-in-index-xt @ execute ;
  310: 
  311: : item-stack-type-name ( item -- addr u )
  312:     item-stack @ stack-type @ type-c-name 2@ ;
  313: 
  314: : fetch-single ( item -- )
  315:  \ fetch a single stack item from its stack
  316:  >r
  317:  r@ item-name 2@ type
  318:  ."  = vm_" r@ item-stack-type-name type
  319:  ." 2" r@ item-type @ print-type-prefix ." ("
  320:  r@ item-in-index r@ item-stack @ stack-access
  321:  ." );" cr
  322:  rdrop ; 
  323: 
  324: : fetch-double ( item -- )
  325:  \ fetch a double stack item from its stack
  326:  >r
  327:  ." vm_two"
  328:  r@ item-stack-type-name type ." 2"
  329:  r@ item-type @ print-type-prefix ." ("
  330:  r@ item-name 2@ type ." , "
  331:  r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access
  332:  ." , "                      -1 under+ ." (Cell)" stack-access
  333:  ." );" cr
  334:  rdrop ;
  335: 
  336: : same-as-in? ( item -- f )
  337:  \ f is true iff the offset and stack of item is the same as on input
  338:  >r
  339:  r@ item-first @ if
  340:      rdrop false exit
  341:  endif
  342:  r@ item-name 2@ prim prim-items-wordlist @ search-wordlist 0= abort" bug"
  343:  execute @
  344:  dup r@ =
  345:  if \ item first appeared in output
  346:    drop false
  347:  else
  348:    dup  item-stack  @ r@ item-stack  @ = 
  349:    swap item-offset @ r@ item-offset @ = and
  350:  endif
  351:  rdrop ;
  352: 
  353: : item-out-index ( item -- n )
  354:     \ n is the index of item (in the in-effect)
  355:     >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ;
  356: 
  357: : really-store-single ( item -- )
  358:  >r
  359:  r@ item-out-index r@ item-stack @ stack-access ."  = vm_"
  360:  r@ item-type @ print-type-prefix ." 2"
  361:  r@ item-stack-type-name type ." ("
  362:  r@ item-name 2@ type ." );"
  363:  rdrop ;
  364: 
  365: : store-single ( item -- )
  366:  >r
  367:  r@ same-as-in?
  368:  if
  369:    r@ item-in-index 0= r@ item-out-index 0= xor
  370:    if
  371:        ." IF_" r@ item-stack @ stack-pointer 2@ type
  372:        ." TOS(" r@ really-store-single ." );" cr
  373:    endif
  374:  else
  375:    r@ really-store-single cr
  376:  endif
  377:  rdrop ;
  378: 
  379: : store-double ( item -- )
  380: \ !! store optimization is not performed, because it is not yet needed
  381:  >r
  382:  ." vm_"
  383:  r@ item-type @ print-type-prefix ." 2two"
  384:  r@ item-stack-type-name type ." ("
  385:  r@ item-name 2@ type ." , "
  386:  r@ item-out-index r@ item-stack @ 2dup stack-access
  387:  ." , "                       -1 under+ stack-access
  388:  ." );" cr
  389:  rdrop ;
  390: 
  391: : single ( -- xt1 xt2 n )
  392:     ['] fetch-single ['] store-single 1 ;
  393: 
  394: : double ( -- xt1 xt2 n )
  395:     ['] fetch-double ['] store-double 2 ;
  396: 
  397: : s, ( addr u -- )
  398: \ allocate a string
  399:  here swap dup allot move ;
  400: 
  401: wordlist constant prefixes
  402: 
  403: : declare ( addr "name" -- )
  404: \ remember that there is a stack item at addr called name
  405:  create , ;
  406: 
  407: : !default ( w addr -- )
  408:     dup @ if
  409: 	2drop \ leave nonzero alone
  410:     else
  411: 	!
  412:     endif ;
  413: 
  414: : create-type { addr u xt1 xt2 n stack -- } ( "prefix" -- )
  415:     \ describes a type
  416:     \ addr u specifies the C type name
  417:     \ stack effect entries of the type start with prefix
  418:     create type% %allot >r
  419:     addr u save-mem r@ type-c-name 2!
  420:     xt1   r@ type-fetch !
  421:     xt2   r@ type-store !
  422:     n     r@ type-size !
  423:     stack r@ type-stack !
  424:     rdrop ;
  425: 
  426: : type-prefix ( xt1 xt2 n stack "prefix" -- )
  427:     get-current >r prefixes set-current
  428:     create-type r> set-current
  429: does> ( item -- )
  430:     \ initialize item
  431:     { item typ }
  432:     typ item item-type !
  433:     typ type-stack @ item item-stack !default
  434:     item item-name 2@ prim prim-items-wordlist @ search-wordlist 0= if
  435: 	item item-name 2@ nextname item declare
  436: 	item item-first on
  437: 	\ typ type-c-name 2@ type space type  ." ;" cr
  438:     else
  439: 	drop
  440: 	item item-first off
  441:     endif ;
  442: 
  443: : execute-prefix ( item addr1 u1 -- )
  444:     \ execute the word ( item -- ) associated with the longest prefix
  445:     \ of addr1 u1
  446:     0 swap ?do
  447: 	dup i prefixes search-wordlist
  448: 	if \ ok, we have the type ( item addr1 xt )
  449: 	    nip execute
  450: 	    UNLOOP EXIT
  451: 	endif
  452: 	-1 s+loop
  453:     \ we did not find a type, abort
  454:     false s" unknown prefix" ?print-error ;
  455: 
  456: : declaration ( item -- )
  457:     dup item-name 2@ execute-prefix ;
  458: 
  459: : declaration-list ( addr1 addr2 -- )
  460:     ['] declaration map-items ;
  461: 
  462: : declarations ( -- )
  463:  wordlist dup prim prim-items-wordlist ! set-current
  464:  prim prim-effect-in prim prim-effect-in-end @ declaration-list
  465:  prim prim-effect-out prim prim-effect-out-end @ declaration-list ;
  466: 
  467: : print-declaration { item -- }
  468:     item item-first @ if
  469: 	item item-type @ type-c-name 2@ type space
  470: 	item item-name 2@ type ." ;" cr
  471:     endif ;
  472: 
  473: : print-declarations ( -- )
  474:     prim prim-effect-in  prim prim-effect-in-end  @ ['] print-declaration map-items
  475:     prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ;
  476:     
  477: : stack-prefix ( stack "prefix" -- )
  478:     get-current >r prefixes set-current
  479:     name tuck nextname create ( stack length ) 2,
  480:     r> set-current
  481: does> ( item -- )
  482:     2@ { item stack prefix-length }
  483:     item item-name 2@ prefix-length /string item item-name 2!
  484:     stack item item-stack !
  485:     item declaration ;
  486: 
  487: \ types pointed to by stacks for use in combined prims
  488: \ !! output-c-combined shouldn't use these names!
  489: : stack-type-name ( addr u "name" -- )
  490:     single 0 create-type ;
  491: 
  492: wordlist constant type-names \ this is here just to meet the requirement
  493:                     \ that a type be a word; it is never used for lookup
  494: 
  495: : stack ( "name" "stack-pointer" "type" -- )
  496:     \ define stack
  497:     name { d: stack-name }
  498:     name { d: stack-pointer }
  499:     name { d: stack-type }
  500:     get-current type-names set-current
  501:     stack-type 2dup nextname stack-type-name
  502:     set-current
  503:     stack-pointer lastxt >body stack-name nextname make-stack ;
  504: 
  505: stack inst-stream IP Cell
  506: ' inst-in-index inst-stream stack-in-index-xt !
  507: ' inst-stream <is> inst-stream-f
  508: \ !! initialize stack-in and stack-out
  509: 
  510: \ offset computation
  511: \ the leftmost (i.e. deepest) item has offset 0
  512: \ the rightmost item has the highest offset
  513: 
  514: : compute-offset { item xt -- }
  515:     \ xt specifies in/out; update stack-in/out and set item-offset
  516:     item item-type @ type-size @
  517:     item item-stack @ xt execute dup @ >r +!
  518:     r> item item-offset ! ;
  519: 
  520: : compute-offset-in ( addr1 addr2 -- )
  521:     ['] stack-in compute-offset ;
  522: 
  523: : compute-offset-out ( addr1 addr2 -- )
  524:     ['] stack-out compute-offset ;
  525: 
  526: : clear-stack { -- }
  527:     dup stack-in off stack-out off ;
  528: 
  529: : compute-offsets ( -- )
  530:     ['] clear-stack map-stacks
  531:     inst-stream clear-stack
  532:     prim prim-effect-in  prim prim-effect-in-end  @ ['] compute-offset-in  map-items
  533:     prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items
  534:     inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;
  535: 
  536: : process-simple ( -- )
  537:     prim prim { W^ key } key cell
  538:     combinations ['] constant insert-wordlist
  539:     declarations compute-offsets
  540:     output @ execute ;
  541: 
  542: : flush-a-tos { stack -- }
  543:     stack stack-out @ 0<> stack stack-in @ 0= and
  544:     if
  545: 	." IF_" stack stack-pointer 2@ 2dup type ." TOS("
  546: 	2dup type ." [0] = " type ." TOS);" cr
  547:     endif ;
  548: 
  549: : flush-tos ( -- )
  550:     ['] flush-a-tos map-stacks ;
  551: 
  552: : fill-a-tos { stack -- }
  553:     stack stack-out @ 0= stack stack-in @ 0<> and
  554:     if
  555: 	." IF_" stack stack-pointer 2@ 2dup type ." TOS("
  556: 	2dup type ." TOS = " type ." [0]);" cr
  557:     endif ;
  558: 
  559: : fill-tos ( -- )
  560:     \ !! inst-stream for prefetching?
  561:     ['] fill-a-tos map-stacks ;
  562: 
  563: : fetch ( addr -- )
  564:     dup item-type @ type-fetch @ execute ;
  565: 
  566: : fetches ( -- )
  567:     prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ;
  568: 
  569: : stack-pointer-update { stack -- }
  570:     \ stack grow downwards
  571:     stack stack-in @ stack stack-out @ -
  572:     ?dup-if \ this check is not necessary, gcc would do this for us
  573: 	stack stack-pointer 2@ type ."  += " 0 .r ." ;" cr
  574:     endif ;
  575: 
  576: : inst-pointer-update ( -- )
  577:     inst-stream stack-in @ ?dup-if
  578: 	." INC_IP(" 0 .r ." );" cr
  579:     endif ;
  580: 
  581: : stack-pointer-updates ( -- )
  582:     inst-pointer-update
  583:     ['] stack-pointer-update map-stacks ;
  584: 
  585: : store ( item -- )
  586: \ f is true if the item should be stored
  587: \ f is false if the store is probably not necessary
  588:  dup item-type @ type-store @ execute ;
  589: 
  590: : stores ( -- )
  591:     prim prim-effect-out prim prim-effect-out-end @ ['] store map-items ;
  592: 
  593: : print-debug-arg { item -- }
  594:     ." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); "
  595:     ." printarg_" item item-type @ print-type-prefix
  596:     ." (" item item-name 2@ type ." );" cr ;
  597:     
  598: : print-debug-args ( -- )
  599:     ." #ifdef VM_DEBUG" cr
  600:     ." if (vm_debug) {" cr
  601:     prim prim-effect-in prim prim-effect-in-end @ ['] print-debug-arg map-items
  602: \    ." fputc('\n', vm_out);" cr
  603:     ." }" cr
  604:     ." #endif" cr ;
  605: 
  606: : print-debug-result { item -- }
  607:     item item-first @ if
  608: 	item print-debug-arg
  609:     endif ;
  610: 
  611: : print-debug-results ( -- )
  612:     cr
  613:     ." #ifdef VM_DEBUG" cr
  614:     ." if (vm_debug) {" cr
  615:     ." fputs(" quote ."  -- " quote ." , vm_out); "
  616:     prim prim-effect-out prim prim-effect-out-end @ ['] print-debug-result map-items
  617:     ." fputc('\n', vm_out);" cr
  618:     ." }" cr
  619:     ." #endif" cr ;
  620: 
  621: : output-super-end ( -- )
  622:     prim prim-c-code 2@ s" SET_IP" search if
  623: 	." SUPER_END;" cr
  624:     endif
  625:     2drop ;
  626: 
  627: : output-c-tail ( -- )
  628:     \ the final part of the generated C code
  629:     output-super-end
  630:     print-debug-results
  631:     ." NEXT_P1;" cr
  632:     stores
  633:     fill-tos
  634:     ." NEXT_P2;" ;
  635: 
  636: : type-c-code ( c-addr u xt -- )
  637:     \ like TYPE, but replaces "TAIL;" with tail code produced by xt
  638:     { xt }
  639:     begin ( c-addr1 u1 )
  640: 	2dup s" TAIL;" search
  641:     while ( c-addr1 u1 c-addr3 u3 )
  642: 	2dup 2>r drop nip over - type
  643: 	xt execute
  644: 	2r> 5 /string
  645: 	\ !! resync #line missing
  646:     repeat
  647:     2drop type ;
  648: 
  649: : print-entry ( -- )
  650:     ." LABEL(" prim prim-c-name 2@ type ." ):" ;
  651:     
  652: : output-c ( -- ) 
  653:  print-entry ."  /* " prim prim-name 2@ type ."  ( " prim prim-stack-string 2@ type ." ) */" cr
  654:  ." /* " prim prim-doc 2@ type ."  */" cr
  655:  ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging
  656:  ." {" cr
  657:  ." DEF_CA" cr
  658:  print-declarations
  659:  ." NEXT_P0;" cr
  660:  flush-tos
  661:  fetches
  662:  print-debug-args
  663:  stack-pointer-updates
  664:  ." {" cr
  665:  ." #line " c-line @ . quote c-filename 2@ type quote cr
  666:  prim prim-c-code 2@ ['] output-c-tail type-c-code
  667:  ." }" cr
  668:  output-c-tail
  669:  ." }" cr
  670:  cr
  671: ;
  672: 
  673: : disasm-arg { item -- }
  674:     item item-stack @ inst-stream = if
  675: 	."   fputc(' ', vm_out); "
  676: 	." printarg_" item item-type @ print-type-prefix
  677: 	." ((" item item-type @ type-c-name 2@ type ." )"
  678: 	." ip[" item item-offset @ 1+ 0 .r ." ]);" cr
  679:     endif ;
  680: 
  681: : disasm-args ( -- )
  682:     prim prim-effect-in prim prim-effect-in-end @ ['] disasm-arg map-items ;
  683: 
  684: : output-disasm ( -- )
  685:     \ generate code for disassembling VM instructions
  686:     ." if (ip[0] == prim[" function-number @ 0 .r ." ]) {" cr
  687:     ."   fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr
  688:     disasm-args
  689:     ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
  690:     ."   goto _endif_;" cr
  691:     ." }" cr ;
  692: 
  693: : output-profile ( -- )
  694:     \ generate code for postprocessing the VM block profile stuff
  695:     ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
  696:     ."   add_inst(b, " quote prim prim-name 2@ type quote ." );" cr
  697:     ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
  698:     prim prim-c-code 2@  s" SET_IP"    search nip nip
  699:     prim prim-c-code 2@  s" SUPER_END" search nip nip or if
  700: 	."   return;" cr
  701:     else
  702: 	."   goto _endif_;" cr
  703:     endif
  704:     ." }" cr ;
  705: 
  706: : output-profile-combined ( -- )
  707:     \ generate code for postprocessing the VM block profile stuff
  708:     ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
  709:     num-combined @ 0 +do
  710: 	."   add_inst(b, " quote
  711: 	combined-prims i th @ prim-name 2@ type
  712: 	quote ." );" cr
  713:     loop
  714:     ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
  715:     combined-prims num-combined @ 1- th @ prim-c-code 2@  s" SET_IP"    search nip nip
  716:     combined-prims num-combined @ 1- th @ prim-c-code 2@  s" SUPER_END" search nip nip or if
  717: 	."   return;" cr
  718:     else
  719: 	."   goto _endif_;" cr
  720:     endif
  721:     ." }" cr ;
  722: 
  723: : output-superend ( -- )
  724:     \ output flag specifying whether the current word ends a dynamic superinst
  725:     prim prim-c-code 2@  s" SET_IP"    search nip nip
  726:     prim prim-c-code 2@  s" SUPER_END" search nip nip or 0<>
  727:     prim prim-c-code 2@  s" SUPER_CONTINUE" search nip nip 0= and
  728:     negate 0 .r ." , /* " prim prim-name 2@ type ."  */" cr ;
  729: 
  730: : gen-arg-parm { item -- }
  731:     item item-stack @ inst-stream = if
  732: 	." , " item item-type @ type-c-name 2@ type space
  733: 	item item-name 2@ type
  734:     endif ;
  735: 
  736: : gen-args-parm ( -- )
  737:     prim prim-effect-in prim prim-effect-in-end @ ['] gen-arg-parm map-items ;
  738: 
  739: : gen-arg-gen { item -- }
  740:     item item-stack @ inst-stream = if
  741: 	."   genarg_" item item-type @ print-type-prefix
  742:         ." (ctp, " item item-name 2@ type ." );" cr
  743:     endif ;
  744: 
  745: : gen-args-gen ( -- )
  746:     prim prim-effect-in prim prim-effect-in-end @ ['] gen-arg-gen map-items ;
  747: 
  748: : output-gen ( -- )
  749:     \ generate C code for generating VM instructions
  750:     ." void gen_" prim prim-c-name 2@ type ." (Inst **ctp" gen-args-parm ." )" cr
  751:     ." {" cr
  752:     ."   gen_inst(ctp, vm_prim[" function-number @ 0 .r ." ]);" cr
  753:     gen-args-gen
  754:     ." }" cr ;
  755: 
  756: : stack-used? { stack -- f }
  757:     stack stack-in @ stack stack-out @ or 0<> ;
  758: 
  759: : output-funclabel ( -- )
  760:   ." &I_" prim prim-c-name 2@ type ." ," cr ;
  761: 
  762: : output-forthname ( -- )
  763:   '" emit prim prim-name 2@ type '" emit ." ," cr ;
  764: 
  765: \  : output-c-func ( -- )
  766: \  \ used for word libraries
  767: \      ." Cell * I_" prim prim-c-name 2@ type ." (Cell *SP, Cell **FP)      /* " prim prim-name 2@ type
  768: \      ."  ( " prim prim-stack-string 2@ type ."  ) */" cr
  769: \      ." /* " prim prim-doc 2@ type ."  */" cr
  770: \      ." NAME(" quote prim prim-name 2@ type quote ." )" cr
  771: \      \ debugging
  772: \      ." {" cr
  773: \      print-declarations
  774: \      \ !! don't know what to do about that
  775: \      inst-stream  stack-used? IF ." Cell *ip=IP;" cr THEN
  776: \      data-stack   stack-used? IF ." Cell *sp=SP;" cr THEN
  777: \      fp-stack     stack-used? IF ." Cell *fp=*FP;" cr THEN
  778: \      return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN
  779: \      flush-tos
  780: \      fetches
  781: \      stack-pointer-updates
  782: \      fp-stack   stack-used? IF ." *FP=fp;" cr THEN
  783: \      ." {" cr
  784: \      ." #line " c-line @ . quote c-filename 2@ type quote cr
  785: \      prim prim-c-code 2@ type
  786: \      ." }" cr
  787: \      stores
  788: \      fill-tos
  789: \      ." return (sp);" cr
  790: \      ." }" cr
  791: \      cr ;
  792: 
  793: : output-label ( -- )  
  794:     ." INST_ADDR(" prim prim-c-name 2@ type ." )," cr ;
  795: 
  796: : output-alias ( -- ) 
  797:     ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ;
  798: 
  799: : output-forth ( -- )  
  800:     prim prim-forth-code @ 0=
  801:     IF    	\ output-alias
  802: 	\ this is bad for ec: an alias is compiled if tho word does not exist!
  803: 	\ JAW
  804:     ELSE  ." : " prim prim-name 2@ type ."   ( "
  805: 	prim prim-stack-string 2@ type ." )" cr
  806: 	prim prim-forth-code 2@ type cr
  807:     THEN ;
  808: 
  809: : output-tag-file ( -- )
  810:     name-filename 2@ last-name-filename 2@ compare if
  811: 	name-filename 2@ last-name-filename 2!
  812: 	#ff emit cr
  813: 	name-filename 2@ type
  814: 	." ,0" cr
  815:     endif ;
  816: 
  817: : output-tag ( -- )
  818:     output-tag-file
  819:     prim prim-name 2@ 1+ type
  820:     127 emit
  821:     space prim prim-name 2@ type space
  822:     1 emit
  823:     name-line @ 0 .r
  824:     ." ,0" cr ;
  825: 
  826: : output-vi-tag ( -- )
  827:     name-filename 2@ type #tab emit
  828:     prim prim-name 2@ type #tab emit
  829:     ." /^" prim prim-name 2@ type ."  *(/" cr ;
  830: 
  831: [IFDEF] documentation
  832: : register-doc ( -- )
  833:     prim prim-name 2@ documentation ['] create insert-wordlist
  834:     prim prim-name 2@ 2,
  835:     prim prim-stack-string 2@ condition-stack-effect 2,
  836:     prim prim-wordset 2@ 2,
  837:     prim prim-c-name 2@ condition-pronounciation 2,
  838:     prim prim-doc 2@ 2, ;
  839: [THEN]
  840: 
  841: 
  842: \ combining instructions
  843: 
  844: \ The input should look like this:
  845: 
  846: \ lit_+ = lit +
  847: 
  848: \ The output should look like this:
  849: 
  850: \  I_lit_+:
  851: \  {
  852: \  DEF_CA
  853: \  Cell _x_ip0;
  854: \  Cell _x_sp0;
  855: \  Cell _x_sp1;
  856: \  NEXT_P0;
  857: \  _x_ip0 = (Cell) IPTOS;
  858: \  _x_sp0 = (Cell) spTOS;
  859: \  INC_IP(1);
  860: \  /* sp += 0; */
  861: \  /* lit ( #w -- w ) */
  862: \  /*  */
  863: \  NAME("lit")
  864: \  {
  865: \  Cell w;
  866: \  w = (Cell) _x_ip0;
  867: \  #ifdef VM_DEBUG
  868: \  if (vm_debug) {
  869: \  fputs(" w=", vm_out); printarg_w (w);
  870: \  fputc('\n', vm_out);
  871: \  }
  872: \  #endif
  873: \  {
  874: \  #line 136 "./prim"
  875: \  }
  876: \  _x_sp1 = (Cell)w;
  877: \  }
  878: \  I_plus:	/* + ( n1 n2 -- n ) */
  879: \  /*  */
  880: \  NAME("+")
  881: \  {
  882: \  DEF_CA
  883: \  Cell n1;
  884: \  Cell n2;
  885: \  Cell n;
  886: \  NEXT_P0;
  887: \  n1 = (Cell) _x_sp0;
  888: \  n2 = (Cell) _x_sp1;
  889: \  #ifdef VM_DEBUG
  890: \  if (vm_debug) {
  891: \  fputs(" n1=", vm_out); printarg_n (n1);
  892: \  fputs(" n2=", vm_out); printarg_n (n2);
  893: \  fputc('\n', vm_out);
  894: \  }
  895: \  #endif
  896: \  {
  897: \  #line 516 "./prim"
  898: \  n = n1+n2;
  899: \  }
  900: \  NEXT_P1;
  901: \  _x_sp0 = (Cell)n;
  902: \  NEXT_P2;
  903: \  }
  904: \  NEXT_P1;
  905: \  spTOS = (Cell)_x_sp0;
  906: \  NEXT_P2;
  907: 
  908: : init-combined ( -- )
  909:     prim to combined
  910:     0 num-combined !
  911:     current-depth max-stacks cells erase
  912:     max-depth     max-stacks cells erase
  913:     min-depth     max-stacks cells erase
  914:     prim prim-effect-in  prim prim-effect-in-end  !
  915:     prim prim-effect-out prim prim-effect-out-end ! ;
  916: 
  917: : max! ( n addr -- )
  918:     tuck @ max swap ! ;
  919: 
  920: : min! ( n addr -- )
  921:     tuck @ min swap ! ;
  922: 
  923: : add-depths { p -- }
  924:     \ combine stack effect of p with *-depths
  925:     max-stacks 0 ?do
  926: 	current-depth i th @
  927: 	p prim-stacks-in  i th @ +
  928: 	dup max-depth i th max!
  929: 	p prim-stacks-out i th @ -
  930: 	dup min-depth i th min!
  931: 	current-depth i th !
  932:     loop ;
  933: 
  934: : add-prim ( addr u -- )
  935:     \ add primitive given by "addr u" to combined-prims
  936:     primitives search-wordlist s" unknown primitive" ?print-error
  937:     execute { p }
  938:     p combined-prims num-combined @ th !
  939:     1 num-combined +!
  940:     p add-depths ;
  941: 
  942: : compute-effects { q -- }
  943:     \ compute the stack effects of q from the depths
  944:     max-stacks 0 ?do
  945: 	max-depth i th @ dup
  946: 	q prim-stacks-in i th !
  947: 	current-depth i th @ -
  948: 	q prim-stacks-out i th !
  949:     loop ;
  950: 
  951: : make-effect-items { stack# items effect-endp -- }
  952:     \ effect-endp points to a pointer to the end of the current item-array
  953:     \ and has to be updated
  954:     stacks stack# th @ { stack }
  955:     items 0 +do
  956: 	effect-endp @ { item }
  957: 	i 0 <# #s stack stack-pointer 2@ holds [char] _ hold #> save-mem
  958: 	item item-name 2!
  959: 	stack item item-stack !
  960: 	stack stack-type @ item item-type !
  961: 	i item item-offset !
  962: 	item item-first on
  963: 	item% %size effect-endp +!
  964:     loop ;
  965: 
  966: : init-effects { q -- }
  967:     \ initialize effects field for FETCHES and STORES
  968:     max-stacks 0 ?do
  969: 	i q prim-stacks-in  i th @ q prim-effect-in-end  make-effect-items
  970: 	i q prim-stacks-out i th @ q prim-effect-out-end make-effect-items
  971:     loop ;
  972: 
  973: : process-combined ( -- )
  974:     combined combined-prims num-combined @ cells
  975:     combinations ['] constant insert-wordlist
  976:     combined-prims num-combined @ 1- th ( last-part )
  977:     @ prim-c-code 2@ prim prim-c-code 2! \ used by output-super-end
  978:     prim compute-effects
  979:     prim init-effects
  980:     output-combined perform ;
  981: 
  982: \ C output
  983: 
  984: : print-item { n stack -- }
  985:     \ print nth stack item name
  986:     stack stack-type @ type-c-name 2@ type space
  987:     ." _" stack stack-pointer 2@ type n 0 .r ;
  988: 
  989: : print-declarations-combined ( -- )
  990:     max-stacks 0 ?do
  991: 	max-depth i th @ min-depth i th @ - 0 +do
  992: 	    i stacks j th @ print-item ." ;" cr
  993: 	loop
  994:     loop ;
  995: 
  996: : part-fetches ( -- )
  997:     fetches ;
  998: 
  999: : part-output-c-tail ( -- )
 1000:     print-debug-results
 1001:     stores ;
 1002: 
 1003: : output-combined-tail ( -- )
 1004:     part-output-c-tail
 1005:     prim >r combined to prim
 1006:     in-part @ >r in-part off
 1007:     output-c-tail
 1008:     r> in-part ! r> to prim ;
 1009: 
 1010: : output-part ( p -- )
 1011:     to prim
 1012:     ." /* " prim prim-name 2@ type ."  ( " prim prim-stack-string 2@ type ." ) */" cr
 1013:     ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging
 1014:     ." {" cr
 1015:     print-declarations
 1016:     part-fetches
 1017:     print-debug-args
 1018:     prim add-depths \ !! right place?
 1019:     ." {" cr
 1020:     ." #line " c-line @ . quote c-filename 2@ type quote cr
 1021:     prim prim-c-code 2@ ['] output-combined-tail type-c-code
 1022:     ." }" cr
 1023:     part-output-c-tail
 1024:     ." }" cr ;
 1025: 
 1026: : output-parts ( -- )
 1027:     prim >r in-part on
 1028:     current-depth max-stacks cells erase
 1029:     num-combined @ 0 +do
 1030: 	combined-prims i th @ output-part
 1031:     loop
 1032:     in-part off
 1033:     r> to prim ;
 1034: 
 1035: : output-c-combined ( -- )
 1036:     print-entry cr
 1037:     \ debugging messages just in parts
 1038:     ." {" cr
 1039:     ." DEF_CA" cr
 1040:     print-declarations-combined
 1041:     ." NEXT_P0;" cr
 1042:     flush-tos
 1043:     fetches
 1044:     \ print-debug-args
 1045:     stack-pointer-updates
 1046:     output-parts
 1047:     output-c-tail
 1048:     ." }" cr
 1049:     cr ;
 1050: 
 1051: : output-forth-combined ( -- )
 1052: ;
 1053: 
 1054: 
 1055: \ peephole optimization rules
 1056: 
 1057: \ in order for this to work as intended, shorter combinations for each
 1058: \ length must be present, and the longer combinations must follow
 1059: \ shorter ones (this restriction may go away in the future).
 1060:   
 1061: : output-peephole ( -- )
 1062:     combined-prims num-combined @ 1- cells combinations search-wordlist
 1063:     s" the prefix for this combination must be defined earlier" ?print-error
 1064:     ." {"
 1065:     execute prim-num @ 5 .r ." ,"
 1066:     combined-prims num-combined @ 1- th @ prim-num @ 5 .r ." ,"
 1067:     combined prim-num @ 5 .r ." }, /* "
 1068:     combined prim-c-name 2@ type ."  */"
 1069:     cr ;
 1070: 
 1071: : output-forth-peephole ( -- )
 1072:     combined-prims num-combined @ 1- cells combinations search-wordlist
 1073:     s" the prefix for this combination must be defined earlier" ?print-error
 1074:     execute prim-num @ 5 .r
 1075:     combined-prims num-combined @ 1- th @ prim-num @ 5 .r
 1076:     combined prim-num @ 5 .r ."  prim, \ "
 1077:     combined prim-c-name 2@ type
 1078:     cr ;
 1079: 
 1080: 
 1081: \ the parser
 1082: 
 1083: eof-char max-member \ the whole character set + EOF
 1084: 
 1085: : getinput ( -- n )
 1086:  rawinput @ endrawinput @ =
 1087:  if
 1088:    eof-char
 1089:  else
 1090:    cookedinput @ c@
 1091:  endif ;
 1092: 
 1093: :noname ( n -- )
 1094:  dup bl > if
 1095:   emit space
 1096:  else
 1097:   .
 1098:  endif ;
 1099: print-token !
 1100: 
 1101: : testchar? ( set -- f )
 1102:  getinput member? ;
 1103: ' testchar? test-vector !
 1104: 
 1105: : checksyncline ( -- )
 1106:     \ when input points to a newline, check if the next line is a
 1107:     \ sync line.  If it is, perform the appropriate actions.
 1108:     rawinput @ >r
 1109:     s" #line " r@ over compare 0<> if
 1110: 	rdrop 1 line +! EXIT
 1111:     endif
 1112:     0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )
 1113:     dup c@ bl = if
 1114: 	char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error
 1115: 	char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2!
 1116: 	char+
 1117:     endif
 1118:     dup c@ nl-char <> 0= s" sync line syntax" ?print-error
 1119:     skipsynclines @ if
 1120: 	dup char+ rawinput !
 1121: 	rawinput @ c@ cookedinput @ c!
 1122:     endif
 1123:     drop ;
 1124: 
 1125: : ?nextchar ( f -- )
 1126:     s" syntax error, wrong char" ?print-error
 1127:     rawinput @ endrawinput @ <> if
 1128: 	rawinput @ c@
 1129: 	1 chars rawinput +!
 1130: 	1 chars cookedinput +!
 1131: 	nl-char = if
 1132: 	    checksyncline
 1133: 	    rawinput @ line-start !
 1134: 	endif
 1135: 	rawinput @ c@ cookedinput @ c!
 1136:     endif ;
 1137: 
 1138: : charclass ( set "name" -- )
 1139:  ['] ?nextchar terminal ;
 1140: 
 1141: : .. ( c1 c2 -- set )
 1142:  ( creates a set that includes the characters c, c1<=c<=c2 )
 1143:  empty copy-set
 1144:  swap 1+ rot do
 1145:   i over add-member
 1146:  loop ;
 1147: 
 1148: : ` ( -- terminal ) ( use: ` c )
 1149:  ( creates anonymous terminal for the character c )
 1150:  char singleton ['] ?nextchar make-terminal ;
 1151: 
 1152: char a char z ..  char A char Z ..  union char _ singleton union  charclass letter
 1153: char 0 char 9 ..					charclass digit
 1154: bl singleton tab-char over add-member			charclass white
 1155: nl-char singleton eof-char over add-member complement	charclass nonl
 1156: nl-char singleton eof-char over add-member
 1157:     char : over add-member complement                   charclass nocolonnl
 1158: bl 1+ maxchar .. char \ singleton complement intersection
 1159:                                                         charclass nowhitebq
 1160: bl 1+ maxchar ..                                        charclass nowhite
 1161: char " singleton eof-char over add-member complement	charclass noquote
 1162: nl-char singleton					charclass nl
 1163: eof-char singleton					charclass eof
 1164: nl-char singleton eof-char over add-member		charclass nleof
 1165: 
 1166: (( letter (( letter || digit )) **
 1167: )) <- c-ident ( -- )
 1168: 
 1169: (( ` # ?? (( letter || digit || ` : )) **
 1170: )) <- stack-ident ( -- )
 1171: 
 1172: (( nowhitebq nowhite ** ))
 1173: <- forth-ident ( -- )
 1174: 
 1175: Variable forth-flag
 1176: Variable c-flag
 1177: 
 1178: (( (( ` e || ` E )) {{ start }} nonl ** 
 1179:    {{ end evaluate }}
 1180: )) <- eval-comment ( ... -- ... )
 1181: 
 1182: (( (( ` f || ` F )) {{ start }} nonl ** 
 1183:    {{ end forth-flag @ IF type cr ELSE 2drop THEN }}
 1184: )) <- forth-comment ( -- )
 1185: 
 1186: (( (( ` c || ` C )) {{ start }} nonl ** 
 1187:    {{ end c-flag @ IF type cr ELSE 2drop THEN }}
 1188: )) <- c-comment ( -- )
 1189: 
 1190: (( ` - nonl ** {{ 
 1191: 	forth-flag @ IF ." [ELSE]" cr THEN
 1192: 	c-flag @ IF ." #else" cr THEN }}
 1193: )) <- else-comment
 1194: 
 1195: (( ` + {{ start }} nonl ** {{ end
 1196: 	dup
 1197: 	IF	c-flag @
 1198: 		IF    ." #ifdef HAS_" bounds ?DO  I c@ toupper emit  LOOP cr
 1199: 		THEN
 1200: 		forth-flag @
 1201: 		IF  ." has? " type ."  [IF]"  cr THEN
 1202: 	ELSE	2drop
 1203: 	    c-flag @      IF  ." #endif"  cr THEN
 1204: 	    forth-flag @  IF  ." [THEN]"  cr THEN
 1205: 	THEN }}
 1206: )) <- if-comment
 1207: 
 1208: (( (( ` g || ` G )) {{ start }} nonl **
 1209:    {{ end
 1210:       forth-flag @ IF  ." group " type cr  THEN
 1211:       c-flag @     IF  ." GROUP(" type ." )" cr  THEN }}
 1212: )) <- group-comment
 1213: 
 1214: (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body
 1215: 
 1216: (( ` \ comment-body nleof )) <- comment ( -- )
 1217: 
 1218: (( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) **
 1219: <- stack-items
 1220: 
 1221: (( {{ prim prim-effect-in }}  stack-items {{ prim prim-effect-in-end ! }}
 1222:    ` - ` - white **
 1223:    {{ prim prim-effect-out }} stack-items {{ prim prim-effect-out-end ! }}
 1224: )) <- stack-effect ( -- )
 1225: 
 1226: (( {{ prim create-prim }}
 1227:    ` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white **
 1228:    (( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white **
 1229:       (( {{ start }}  c-ident {{ end prim prim-c-name 2! }} )) ??
 1230:    )) ??  nleof
 1231:    (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ??
 1232:    {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl **  nleof white ** )) ** {{ end prim prim-c-code 2! skipsynclines on }}
 1233:    (( ` :  white ** nleof
 1234:       {{ start }} (( nonl ++  nleof white ** )) ++ {{ end prim prim-forth-code 2! }}
 1235:    )) ?? {{ process-simple }}
 1236:    nleof
 1237: )) <- simple-primitive ( -- )
 1238: 
 1239: (( {{ init-combined }}
 1240:    ` = white ** (( {{ start }} forth-ident {{ end add-prim }} white ** )) ++
 1241:    nleof {{ process-combined }}
 1242: )) <- combined-primitive
 1243: 
 1244: (( {{ make-prim to prim 0 to combined
 1245:       line @ name-line ! filename 2@ name-filename 2!
 1246:       function-number @ prim prim-num !
 1247:       start }} forth-ident {{ end 2dup prim prim-name 2! prim prim-c-name 2! }}  white ++
 1248:    (( ` / white ** {{ start }} c-ident {{ end prim prim-c-name 2! }} white ** )) ??
 1249:    (( simple-primitive || combined-primitive )) {{ 1 function-number +! }}
 1250: )) <- primitive ( -- )
 1251: 
 1252: (( (( comment || primitive || nl white ** )) ** eof ))
 1253: parser primitives2something
 1254: warnings @ [IF]
 1255: .( parser generated ok ) cr
 1256: [THEN]
 1257: 
 1258: 
 1259: \ run with gforth-0.5.0 (slurp-file is missing)
 1260: [IFUNDEF] slurp-file
 1261: : slurp-file ( c-addr1 u1 -- c-addr2 u2 )
 1262:     \ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents
 1263:     r/o bin open-file throw >r
 1264:     r@ file-size throw abort" file too large"
 1265:     dup allocate throw swap
 1266:     2dup r@ read-file throw over <> abort" could not read whole file"
 1267:     r> close-file throw ;
 1268: [THEN]
 1269: 
 1270: : primfilter ( addr u -- )
 1271:     \ process the string at addr u
 1272:     over dup rawinput ! dup line-start ! cookedinput !
 1273:     + endrawinput !
 1274:     checksyncline
 1275:     primitives2something ;    
 1276: 
 1277: : process-file ( addr u xt-simple x-combined -- )
 1278:     output-combined ! output !
 1279:     save-mem 2dup filename 2!
 1280:     slurp-file
 1281:     warnings @ if
 1282: 	." ------------ CUT HERE -------------" cr  endif
 1283:     primfilter ;
 1284: 
 1285: \  : process      ( xt -- )
 1286: \      bl word count rot
 1287: \      process-file ;

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