File:  [gforth] / gforth / prims2x.fs
Revision 1.116: download - view: text, annotated - select for diffs
Sun Sep 22 14:21:30 2002 UTC (17 years, 1 month ago) by anton
Branches: MAIN
CVS tags: HEAD
added include-skipped-insts to prims2x.fs

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

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