--- gforth/prims2x.fs 2005/07/28 19:15:00 1.158 +++ 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 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). @@ -51,9 +50,16 @@ \ (stack-in-index-xt and a test for stack==instruction-stream); there \ should be only one. + \ 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 @@ -102,6 +108,9 @@ variable include-skipped-insts \ inline arguments (false) include-skipped-insts off +2variable threaded-code-pointer-type \ type used for geninst etc. +s" Inst **" threaded-code-pointer-type 2! + variable immarg \ values for immediate arguments (to be used in IMM_ARG macros) $12340000 immarg ! @@ -134,15 +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 - outfile-id >r try - stderr to outfile-id - filename 2@ type ." :" line @ 0 .r ." : " addr u type cr - print-error-line - 0 - recover endtry - r> to outfile-id throw + addr u ['] print-error stderr outfile-execute 1 (bye) \ abort endif ; @@ -201,6 +208,7 @@ struct% end-struct ss% \ stack-state struct% + cell% field state-enabled cell% field state-number cell% max-stacks * field state-sss end-struct state% @@ -362,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 ( -- ) @@ -500,8 +508,8 @@ defer inst-stream-f ( -- stack ) ." vm_two" r@ item-stack-type-name type ." 2" r@ item-type @ print-type-prefix ." (" - r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-read - ." , " -1 under+ ." (Cell)" stack-read + r@ item-in-index r@ item-stack @ 2dup stack-read + ." , " -1 under+ stack-read ." , " r@ item-name 2@ type ." )" cr rdrop ; @@ -676,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 @@ -751,11 +759,18 @@ stack inst-stream IP Cell : state ( "name" -- ) \ create a state initialized with default-sss create state% %allot { s } + s state-enabled on next-state-number @ s state-number ! 1 next-state-number +! max-stacks 0 ?do default-ss s state-sss i th ! loop ; +: state-disable ( state -- ) + state-enabled off ; + +: state-enabled? ( state -- f ) + state-enabled @ ; + : .state ( state -- ) 0 >body - >name .name ; @@ -906,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] ) @@ -922,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 @ - @@ -1038,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 -- ) @@ -1169,9 +1189,10 @@ variable tail-nextp2 \ xt to execute for : output-gen ( -- ) \ generate C code for generating VM instructions - ." void gen_" prim prim-c-name 2@ type ." (Inst **ctp" gen-args-parm ." )" cr + ." void gen_" prim prim-c-name 2@ type ." (" + threaded-code-pointer-type 2@ type ." ctp" gen-args-parm ." )" cr ." {" cr - ." gen_inst(ctp, vm_prim[" function-number @ 0 .r ." ]);" cr + ." gen_inst(ctp, " function-number @ 0 .r ." );" cr gen-args-gen ." }" cr ; @@ -1332,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 @@ -1457,6 +1479,7 @@ variable reprocessed-num 0 reprocessed-n : state-prim1 { in-state out-state prim -- } in-state out-state state-default dup d= ?EXIT + in-state state-enabled? out-state state-enabled? and 0= ?EXIT in-state to state-in out-state to state-out prim reprocess-simple ; @@ -1538,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 ! ; @@ -1837,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 @@ -1854,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 @@ -1874,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 }}