--- gforth/prims2x.fs 1994/08/25 15:25:33 1.6 +++ gforth/prims2x.fs 1995/11/07 18:06:57 1.16 @@ -1,3 +1,24 @@ +\ converts primitives to, e.g., C code + +\ Copyright (C) 1995 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 +\ of the License, or (at your option) any later version. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +\ 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., 675 Mass Ave, Cambridge, MA 02139, USA. + + \ This is not very nice (hard limits, no checking, assumes 1 chars = 1) \ Optimizations: @@ -21,7 +42,8 @@ warnings off -[IFUNDEF] vocabulary include search-order.fs [THEN] +[IFUNDEF] vocabulary include search-order.fs [THEN] +[IFUNDEF] environment? include environ.fs [THEN] include gray.fs 100 constant max-effect \ number of things on one side of a stack effect @@ -37,7 +59,7 @@ maxchar 1+ constant eof-char begin ( c-addr file-id ) 2dup batch-size swap read-file if - abort" I/O error" + true abort" I/O error" endif ( c-addr file-id actual-size ) rot over + -rot batch-size <> @@ -89,7 +111,7 @@ variable effect-out-end ( pointer ) 2variable effect-in-size 2variable effect-out-size -variable primitive-number -9 primitive-number ! +variable primitive-number -10 primitive-number ! \ for several reasons stack items of a word are stored in a wordlist \ since neither forget nor marker are implemented yet, we make a new @@ -241,22 +263,25 @@ constant type-description : fetch-single ( item -- ) >r - r@ item-name 2@ type ." = (" + r@ item-name 2@ type + ." = (" r@ item-type @ type-c-name 2@ type ." ) " r@ item-d-offset @ effect-in-size 2@ data-stack-access ." ;" cr rdrop ; : fetch-double ( item -- ) >r - ." {Double_Store _d; _d.cells.low = " + r@ item-name 2@ type + ." = ({Double_Store _d; _d.cells.low = " r@ item-d-offset @ dup effect-in-size 2@ data-stack-access - ." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access ." ; " - r@ item-name 2@ type ." = _d.dcell;}" cr + ." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access + ." ; _d.dcell;});" cr rdrop ; : fetch-float ( item -- ) >r - r@ item-name 2@ type ." = " + r@ item-name 2@ type + ." = " \ ." (" r@ item-type @ type-c-name 2@ type ." ) " r@ item-f-offset @ effect-in-size 2@ fp-stack-access ." ;" cr rdrop ; @@ -265,9 +290,7 @@ constant type-description \ f is true iff the offset of item is the same as on input >r r@ item-name 2@ items @ search-wordlist 0= - if - ." bug" cr abort - endif + abort" bug" execute @ dup r@ = if \ item first appeared in output @@ -313,9 +336,7 @@ constant type-description \ f is true iff the offset of item is the same as on input >r r@ item-name 2@ items @ search-wordlist 0= - if - ." bug" cr abort - endif + abort" bug" execute @ dup r@ = if \ item first appeared in output @@ -348,13 +369,13 @@ constant type-description endif rdrop ; -: single-type ( -- xt n1 n2 ) +: single-type ( -- xt1 xt2 n1 n2 ) ['] fetch-single ['] store-single 1 0 ; -: double-type ( -- xt n1 n2 ) +: double-type ( -- xt1 xt2 n1 n2 ) ['] fetch-double ['] store-double 2 0 ; -: float-type ( -- xt n1 n2 ) +: float-type ( -- xt1 xt2 n1 n2 ) ['] fetch-float ['] store-float 0 1 ; : s, ( addr u -- ) @@ -407,7 +428,7 @@ set-current endif -1 s+loop \ we did not find a type, abort - ." unknown type prefix" cr ABORT ; + true abort" unknown type prefix" ; : declare ( addr "name" -- ) \ remember that there is a stack item at addr called name @@ -429,6 +450,9 @@ set-current i declaration item-descr +loop ; +: fetch ( addr -- ) + dup item-type @ type-fetch-handler execute ; + : declarations ( -- ) wordlist dup items ! set-current effect-in effect-in-end @ declaration-list @@ -480,16 +504,13 @@ set-current ." IF_TOS(TOS = sp[0]);" cr endif ; -: fetch ( addr -- ) - dup item-type @ type-fetch-handler execute ; - : fetches ( -- ) effect-in-end @ effect-in ?do i fetch item-descr +loop ; : stack-pointer-updates ( -- ) -\ we do not check if an update is a noop; gcc does this for us +\ we need not check if an update is a noop; gcc does this for us effect-in-size 2@ effect-out-size 2@ rot swap - ( d-in d-out f-diff ) @@ -507,24 +528,30 @@ set-current i store item-descr +loop ; +: .stack-list ( start end -- ) + swap ?do + i item-name 2@ type space + item-descr +loop ; + : output-c ( -- ) ." I_" c-name 2@ type ." : /* " forth-name 2@ type ." ( " stack-string 2@ type ." ) */" cr ." /* " doc 2@ type ." */" cr + ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging ." {" cr ." DEF_CA" cr declarations compute-offsets \ for everything else + ." NEXT_P0;" cr flush-tos fetches - stack-pointer-updates cr - ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging + stack-pointer-updates ." {" cr c-code 2@ type ." }" cr ." NEXT_P1;" cr stores fill-tos - ." NEXT1_P2;" cr + ." NEXT_P2;" cr ." }" cr cr ; @@ -536,11 +563,30 @@ set-current primitive-number @ . ." alias " forth-name 2@ type cr -1 primitive-number +! ; +: output-forth ( -- ) + forth-code @ 0= + IF output-alias + ELSE ." : " forth-name 2@ type ." ( " + effect-in effect-in-end @ .stack-list ." -- " + effect-out effect-out-end @ .stack-list ." )" cr + forth-code 2@ type cr + -1 primitive-number +! + THEN ; + +[IFDEF] documentation +: register-doc ( -- ) + get-current documentation set-current + forth-name 2@ nextname create + forth-name 2@ 2, + stack-string 2@ condition-stack-effect 2, + wordset 2@ 2, + c-name 2@ condition-pronounciation 2, + doc 2@ 2, + set-current ; +[THEN] + : process-file ( addr u xt -- ) - >r r/o open-file - if - ." cannot open file" cr abort - endif + >r r/o open-file abort" cannot open file" warnings @ if ." ------------ CUT HERE -------------" cr endif r> primfilter ;