--- gforth/prims2x.fs 2007/02/18 18:30:51 1.164 +++ gforth/prims2x.fs 2011/11/13 00:45:20 1.174 @@ -1,12 +1,12 @@ \ converts primitives to, e.g., C code -\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2009,2010 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License -\ as published by the Free Software Foundation; either version 2 +\ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, @@ -15,8 +15,7 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. \ This is not very nice (hard limits, no checking, assumes 1 chars = 1). @@ -55,6 +54,12 @@ \ for backwards compatibility, jaw require compat/strcomp.fs +[undefined] outfile-execute [if] + : outfile-execute ( ... xt file-id -- ... ) + \ unsafe replacement + outfile-id >r to outfile-id execute r> to outfile-id ; +[then] + warnings off \ redefinitions of kernel words not present in gforth-0.6.1 @@ -138,12 +143,13 @@ $12340000 immarg ! over - type cr line-start @ rawinput @ over - typewhite ." ^" cr ; +: print-error { addr u -- } + filename 2@ type ." :" line @ 0 .r ." : " addr u type cr + print-error-line ; + : ?print-error { f addr u -- } f ?not? if - stderr >outfile - filename 2@ type ." :" line @ 0 .r ." : " addr u type cr - print-error-line - outfile< + addr u ['] print-error stderr outfile-execute 1 (bye) \ abort endif ; @@ -364,7 +370,7 @@ variable name-line 2variable last-name-filename Variable function-number 0 function-number ! Variable function-old 0 function-old ! -: function-diff ( n -- ) +: function-diff ( -- ) ." GROUPADD(" function-number @ function-old @ - 0 .r ." )" cr function-number @ function-old ! ; : forth-fdiff ( -- ) @@ -678,7 +684,7 @@ get-current prefixes set-current set-current create ...-item ( -- addr ) \ just used for letting stack-prefixes work on it -item% %allot \ stores the stack temporarily until used by ... +item% %allot drop \ stores the stack temporarily until used by ... : init-item1 ( addr1 addr u -- addr2 ) \ initialize item at addr1 with name addr u, next item is at addr2 @@ -915,11 +921,14 @@ stack inst-stream IP Cell : stack-pointer-update { stack -- } \ and moves \ stacks grow downwards +\ ." /* stack pointer update " stack stack-pointer 2@ type ." */" cr stack stack-prim-stacks-sync @ if +\ ." /* synced " stack stack-in ? stack stack-out ? stack state-in stack-offset . ." */" cr stack stack-in @ stack state-in stack-offset - stack swap update-stack-pointer else +\ ." /* unsynced " stack stack-in ? stack stack-out ? ." */" cr stack stack-diff ( in-out ) stack state-in stack-offset - stack state-out stack-offset + ( [in-in_offset]-[out-out_offset] ) @@ -931,6 +940,7 @@ stack inst-stream IP Cell ['] stack-pointer-update map-stacks ; : stack-pointer-update2 { stack -- } +\ ." /* stack pointer update2 " stack stack-pointer 2@ type ." */" cr stack stack-prim-stacks-sync @ if stack state-out stack-offset stack stack-out @ - @@ -1047,6 +1057,7 @@ variable tail-nextp2 \ xt to execute for tail-nextp2 @ output-c-tail1-no-stores ; : output-c-tail2-no-stores ( -- ) + prim prim-c-code 2@ s" VM_JUMP(" search nip nip abort" Currently VM_JUMP is not supported in static superinstructions" ['] output-label2 output-c-tail1-no-stores ; : type-c-code ( c-addr u xt -- ) @@ -1342,6 +1353,7 @@ is output-c-prim-num \ NEXT_P2; : init-combined ( -- ) + ['] clear-prim-stacks-sync map-stacks prim to combined 0 num-combined ! current-depth max-stacks cells erase @@ -1549,8 +1561,8 @@ variable reprocessed-num 0 reprocessed-n stores ; : output-combined-tail ( -- ) - part-output-c-tail in-part @ >r in-part off + part-output-c-tail combined ['] output-c-tail-no-stores prim-context r> in-part ! ; @@ -1848,15 +1860,18 @@ Variable c-flag )) <- else-comment (( ` + {{ start }} nonl ** {{ end - dup - IF c-flag @ - IF - function-diff - ." #ifdef HAS_" bounds ?DO I c@ toupper emit LOOP cr - THEN - forth-flag @ - IF forth-fdiff ." has? " type ." [IF]" cr THEN - ELSE 2drop + dup + IF + c-flag @ IF + function-diff + ." #ifdef HAS_" 2dup bounds ?DO I c@ toupper emit LOOP cr + THEN + forth-flag @ IF + forth-fdiff ." has? " 2dup type ." [IF]" cr + THEN + 2drop + ELSE + 2drop c-flag @ IF function-diff ." #endif" cr THEN forth-flag @ IF forth-fdiff ." [THEN]" cr THEN @@ -1865,9 +1880,10 @@ Variable c-flag (( (( ` g || ` G )) {{ start }} nonl ** {{ end - forth-flag @ IF forth-fdiff ." group " type cr THEN + forth-flag @ IF forth-fdiff ." group " 2dup type cr THEN c-flag @ IF function-diff - ." GROUP(" type ." , " function-number @ 0 .r ." )" cr THEN }} + ." GROUP(" 2dup type ." , " function-number @ 0 .r ." )" cr THEN + 2drop }} )) <- group-comment (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body @@ -1885,7 +1901,7 @@ Variable c-flag (( {{ prim create-prim prim init-simple }} ` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white ** (( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white ** - (( {{ start }} c-ident {{ end 2dup prim-c-name-2! }} )) ?? + (( {{ start }} c-ident {{ end prim-c-name-2! }} )) ?? )) ?? nleof (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ?? {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }}