--- gforth/prims2x.fs 2002/12/28 17:18:27 1.125 +++ gforth/prims2x.fs 2003/03/22 10:04:07 1.135 @@ -1,6 +1,6 @@ \ converts primitives to, e.g., C code -\ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -63,7 +63,7 @@ warnings off \ warnings on include ./gray.fs -32 constant max-effect \ number of things on one side of a stack effect +128 constant max-effect \ number of things on one side of a stack effect 4 constant max-stacks \ the max. number of stacks (including inst-stream). 255 constant maxchar maxchar 1+ constant eof-char @@ -162,6 +162,7 @@ struct% cell% 2* field stack-pointer \ stackpointer name cell% field stack-type \ name for default type of stack items cell% field stack-in-index-xt \ ( in-size item -- in-index ) + cell% field stack-access-transform \ ( nitem -- index ) end-struct stack% struct% @@ -197,7 +198,9 @@ create stacks max-stacks cells allot \ a 1 next-stack-number +! r@ stack-type ! save-mem r@ stack-pointer 2! - ['] stack-in-index r> stack-in-index-xt ! ; + ['] stack-in-index r@ stack-in-index-xt ! + ['] noop r@ stack-access-transform ! + rdrop ; : map-stacks { xt -- } \ perform xt for all stacks @@ -333,13 +336,15 @@ defer inst-stream-f ( -- stack ) \ stack access stuff -: normal-stack-access1 ( n stack -- ) - stack-pointer 2@ type - dup - if - ." [" 0 .r ." ]" +: normal-stack-access0 { n stack -- } + n stack stack-access-transform @ execute ." [" 0 .r ." ]" ; + +: normal-stack-access1 { n stack -- } + stack stack-pointer 2@ type + n if + n stack normal-stack-access0 else - drop ." TOS" + ." TOS" endif ; : normal-stack-access ( n stack -- ) @@ -603,7 +608,7 @@ wordlist constant type-names \ this is h get-current type-names set-current stack-type 2dup nextname stack-type-name set-current - stack-pointer lastxt >body stack-name nextname make-stack ; + stack-pointer latestxt >body stack-name nextname make-stack ; stack inst-stream IP Cell ' inst-in-index inst-stream stack-in-index-xt ! @@ -626,11 +631,9 @@ stack inst-stream IP Cell : compute-offset-out ( addr1 addr2 -- ) ['] stack-out compute-offset ; -: clear-stack ( stack -- ) - dup stack-in off stack-out off ; - : compute-offsets ( -- ) - ['] clear-stack map-stacks + prim prim-stacks-in max-stacks cells erase + prim prim-stacks-out max-stacks cells erase prim prim-effect-in prim prim-effect-in-end @ ['] compute-offset-in map-items prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ; @@ -645,7 +648,7 @@ stack inst-stream IP Cell stack stack-out @ 0<> stack stack-in @ 0= and if ." IF_" stack stack-pointer 2@ 2dup type ." TOS(" - 2dup type ." [0] = " type ." TOS);" cr + 2dup type 0 stack normal-stack-access0 ." = " type ." TOS);" cr endif ; : flush-tos ( -- ) @@ -655,7 +658,7 @@ stack inst-stream IP Cell stack stack-out @ 0= stack stack-in @ 0<> and if ." IF_" stack stack-pointer 2@ 2dup type ." TOS(" - 2dup type ." TOS = " type ." [0]);" cr + 2dup type ." TOS = " type 0 stack normal-stack-access0 ." );" cr endif ; : fill-tos ( -- ) @@ -668,6 +671,12 @@ stack inst-stream IP Cell : fetches ( -- ) prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ; +: stack-update-transform ( n1 stack -- n2 ) + \ n2 is the number by which the stack pointer should be + \ incremented to pop n1 items + stack-access-transform @ dup >r execute + 0 r> execute - ; + : stack-pointer-update { stack -- } \ stacks grow downwards stack stack-diff @@ -675,7 +684,8 @@ stack inst-stream IP Cell stack inst-stream = if ." INC_IP(" 0 .r ." );" cr else - stack stack-pointer 2@ type ." += " 0 .r ." ;" cr + stack stack-pointer 2@ type ." += " + stack stack-update-transform 0 .r ." ;" cr endif endif ; @@ -923,7 +933,7 @@ variable tail-nextp2 \ xt to execute for \ cr ; : output-label ( -- ) - ." INST_ADDR(" prim prim-c-name 2@ type ." )" cr ; + ." INST_ADDR(" prim prim-c-name 2@ type ." )," cr ; : output-alias ( -- ) ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ; @@ -1316,25 +1326,25 @@ print-token ! getinput member? ; ' testchar? test-vector ! -: checksyncline ( -- ) +: checksynclines ( -- ) \ when input points to a newline, check if the next line is a \ sync line. If it is, perform the appropriate actions. - rawinput @ >r - s" #line " r@ over compare if - rdrop 1 line +! EXIT - endif - 0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr ) - dup c@ bl = if - char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error - char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2! - char+ - endif - dup c@ nl-char <> 0= s" sync line syntax" ?print-error - skipsynclines @ if - dup char+ rawinput ! - rawinput @ c@ cookedinput @ c! - endif - drop ; + rawinput @ begin >r + s" #line " r@ over compare if + rdrop 1 line +! EXIT + endif + 0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr ) + dup c@ bl = if + char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error + char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2! + char+ + endif + dup c@ nl-char <> 0= s" sync line syntax" ?print-error + skipsynclines @ if + char+ dup rawinput ! + rawinput @ c@ cookedinput @ c! + endif + again ; : ?nextchar ( f -- ) s" syntax error, wrong char" ?print-error @@ -1343,10 +1353,11 @@ print-token ! 1 chars rawinput +! 1 chars cookedinput +! nl-char = if - checksyncline + checksynclines rawinput @ line-start ! endif - rawinput @ c@ cookedinput @ c! + rawinput @ c@ + cookedinput @ c! endif ; : charclass ( set "name" -- ) @@ -1491,13 +1502,24 @@ warnings @ [IF] \ process the string at addr u over dup rawinput ! dup line-start ! cookedinput ! + endrawinput ! - checksyncline + checksynclines primitives2something ; +: unixify ( c-addr u1 -- c-addr u2 ) + \ delete crs from the string + bounds tuck tuck ?do ( c-addr1 ) + i c@ dup #cr <> if + over c! char+ + else + drop + endif + loop + over - ; + : process-file ( addr u xt-simple x-combined -- ) output-combined ! output ! save-mem 2dup filename 2! - slurp-file + slurp-file unixify warnings @ if ." ------------ CUT HERE -------------" cr endif primfilter ;