gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.161 and 1.170

-version 1.161, Fri Jan 27 10:43:52 2006 UTC
+version 1.170, Sun Jan 18 18:41:55 2009 UTC
  Line 1
  Line 1
  Line 1
  \ converts primitives to, e.g., C code
- \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005 Free Software Foundation, Inc.
+ \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007 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,
  Line 15
  Line 15
  Line 15
  \ 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
+ \ along with this program. If not, see http://www.gnu.org/licenses/.
- \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  \ This is not very nice (hard limits, no checking, assumes 1 chars = 1).
- Line 55
+ Line 54
  Line 55
  Line 54
  \ 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
- Line 138
+ Line 143
  Line 138
  Line 143
      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
+         addr u ['] print-error stderr outfile-execute
-             stderr to outfile-id
-             filename 2@ type ." :" line @ 0 .r ." : " addr u type cr
-             print-error-line
-         recover endtry
-         r> to outfile-id throw
 (bye) \ abort
      endif ;
- Line 367
+ Line 370
  Line 367
  Line 370
 variable 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 ( -- )
- Line 505
+ Line 508
  Line 505
  Line 508
      ." 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
+     r@ item-in-index r@ item-stack @ 2dup stack-read
-     ." , "                      -1 under+ ." (Cell)" stack-read
+     ." , "                      -1 under+ stack-read
      ." , " r@ item-name 2@ type
      ." )" cr
      rdrop ;
- Line 681
+ Line 684
  Line 681
  Line 684
  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
- Line 1552
+ Line 1555
  Line 1552
  Line 1555
      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 ! ;
- Line 1852
+ Line 1855
  Line 1852
  Line 1855
  (( ` + {{ start }} nonl ** {{ end
          dup
-         IF      c-flag @
              IF
+             c-flag @ IF
                  function-diff
-                 ." #ifdef HAS_" bounds ?DO  I c@ toupper emit  LOOP cr
+                 ." #ifdef HAS_" 2dup bounds ?DO  I c@ toupper emit  LOOP cr
+             THEN
+             forth-flag @ IF
+                 forth-fdiff  ." has? " 2dup type ."  [IF]"  cr
                  THEN
-                 forth-flag @
+drop
-                 IF  forth-fdiff  ." has? " type ."  [IF]"  cr THEN
+         ELSE
-         ELSE    2drop
+drop
              c-flag @      IF
                  function-diff  ." #endif" cr THEN
              forth-flag @  IF  forth-fdiff  ." [THEN]"  cr THEN
- Line 1868
+ Line 1874
  Line 1868
  Line 1874
  (( (( ` 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
+drop }}
  )) <- group-comment
  (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body
- Line 1888
+ Line 1895
  Line 1888
  Line 1895
  (( {{ 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 }}

-Generate output suitable for use with a patch program
+Legend:



Removed from v.1.161
 


changed lines


 
Added in v.1.170
 Legend:



Removed from v.1.161
 


changed lines


 
Added in v.1.170
-Removed from v.1.161
+Added in v.1.170

CVS Admin

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.161 and 1.170

ViewCVS and CVS Help